Chuyển đến nội dung
Diễn đàn CADViet
  • Thông báo

    • Nguyen Hoanh

      CADViet đã hoàn tất nâng cấp   14/09/2017

      Chào các bạn, CADViet đã hoàn tất việc nâng cấp lên phiên bản mới. Tất cả các chức năng đã hoạt động theo kỳ vọng của ban quản trị. Nếu có vấn đề gì cần phản hồi, các bản post ở đây nhé: Trân trọng, Nguyễn Hoành.
Nguyen Hoanh

Viết Lisp theo yêu cầu

Các bài được khuyến nghị

tomboy    20
khẩn cấp !!!

chào các bác, e muốn xin lisp có thể thay đổi toàn bộ mầu của các đối tượng có trong bản vẽ ( kể cả block ) về chế độ "by layer" không ah? chẳng là e phải chuyển toàn bộ các đối tượng block của bên xây dựng về mầu 8

phải ý bạn như thế này không, chạy thử đi nhé! lệnh CHC tức là change color

(defun c:chc ( / sset i entg clor)
 (setq sset (ssget))
 (if sset
   (progn
     (setq len	(sslength sset)
    i	0
     )
     (repeat len
(setq entg (entget (ssname sset i))
      clor (assoc 62 entg)
      i	   (1+ i)
)
(if clor
  (progn
    (setq entg (vl-remove clor entg))
    (entmake entg)
    (entdel (cdr (assoc -1 entg)))
  )
)
     )
   )
 )
)

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
HoangSon614    66
mình chỉ sửa để chương trình của bạn chạy được thôi, chứ diện tích tính được lớn gấp 2 lần diện tích của a cad là do source của bạn S = S+2tt mình nghĩ do công việc của bạn cần phải nhân đôi diện tích nên mình vẫn giữ nguyên cái đó.

theo yêu cầu của bạn thì mình sửa lại cho đúng với diện tích của máy nhé.

(defun c:gdt (/ oldim p1 frome cur toe ss ss2 tt S entn ans po cao te ente)
 (setq oldim (getvar "DimZin"))
 (setvar "DimZin" 0)
 (setvar "cmdecho" 0)
 (setq entn '()
S 0)
 (While (setq p1 (getpoint "\n Pick diem vao mien de lay dien tich : "))
   (if p1 (progn
     (setq frome (entlast))
     (command ".boundary" p1 "")
     (setq toe (entlast))
     (if (not (eq frome toe))
       (progn
	 (command "area" "e" "l" "")
                (setq tt (getvar "area"))
	 (setq S (+ S tt))
	 (setq entn(append entn (list toe)))
	 )
       )
     )
     )
 )
 (if entn
   (progn
   (setq len(length entn)
  i 0)
   (repeat len
     (entdel (nth i entn))
     (setq i (1+ i))
     )
   )
   )
 (setq ok "YES")
 (while (= ok "YES")
   (setq ent
   (entsel
     "\nChon Text de thay gia tri dien tich :  "
   )
   )
   (if	(not ent)
     (progn
(setq err (getvar "errno"))
(if (= err 52)
  (setq ok "NO" ans "D")
)
     )
     (progn
     (if (= (cdr(assoc 0 (entget(car ent)))) "TEXT")
(setq te (car ent) ok "NO" ans "T"))
	)
   )
 )
 (if (or (= ans "d") (= ans "D"))
   (progn
     (setq po (getpoint "\n Chon diem chen de ghi dien tich :"))
     (setq cao (getdist "\n Nhap chieu cao chu : "))
     (wtxt (rtos S 2 2) po 0 cao)

   )
 )
 (if (or (= ans "t") (= ans "T"))
   (progn
     (setq ente (entget te))
     (setq ente (subst (cons 1 (rtos S 2 2)) (assoc 1 ente) ente))
     (entmod ente)

   )
 )
 (setvar "DimZin" oldim)
 (Princ)
)
				;
				;
				;
(defun wtxt (txt p ang h / sty)
 (setq sty (getvar "textstyle"))
 (entmake (list (cons 0 "TEXT")
	 (cons 7 sty)
	 (cons 1 txt)
	 (cons 10 p)
	 (cons 11 p)
	 (cons 72 2)
	 (cons 73 2)
	 (cons 50 ang)
	 (cons 40 h)
	 (cons 41 0.8)
   )
 )
)

Mình cảm ơn bạn đã quan tâm, lisp chạy rất tốt nhưng mình làm phiền bạn tý nữa nha, cố gắng giúp mình

1. Mình không muốn khi chạy có cái đuôi lòng thòng phía sau:

Command: ttdt

Unknown command "TTDT". Press F1 for help.

Unknown command "TTDT". Press F1 for help.

2. Vấn đề này mình đang đau đầu không biết giải quyết ra sau, mình muốn bạn chỉnh lại dùm mình khi diện tích được tính ra là một giá trị thực tế (cụ thể như: một mảnh đất với KT: 100x100 = 10.000m2, còn với lisp này thì giá trị được tính là 100m2 với tỷ lệ vẽ 1/10). Bạn có thể thêm chuỗi S= trước giá trị d/t và thêm cuỗi m2 (mét vuông) sau giá trị d/t và gán text là Vni-Helve, còn những cái khác vẫn giữ nguyên.

Nếu được bạn bớt chút thời gian giúp mình, cảm ơn bạn nhiều.

Chỉnh sửa theo HoangSon614

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
HoangSon614    66
mình chỉ sửa để chương trình của bạn chạy được thôi, chứ diện tích tính được lớn gấp 2 lần diện tích của a cad là do source của bạn S = S+2tt mình nghĩ do công việc của bạn cần phải nhân đôi diện tích nên mình vẫn giữ nguyên cái đó.

theo yêu cầu của bạn thì mình sửa lại cho đúng với diện tích của máy nhé.

(defun c:gdt (/ oldim p1 frome cur toe ss ss2 tt S entn ans po cao te ente)
 (setq oldim (getvar "DimZin"))
 (setvar "DimZin" 0)
 (setvar "cmdecho" 0)
 (setq entn '()
S 0)
 (While (setq p1 (getpoint "\n Pick diem vao mien de lay dien tich : "))
   (if p1 (progn
     (setq frome (entlast))
     (command ".boundary" p1 "")
     (setq toe (entlast))
     (if (not (eq frome toe))
       (progn
	 (command "area" "e" "l" "")
                (setq tt (getvar "area"))
	 (setq S (+ S tt))
	 (setq entn(append entn (list toe)))
	 )
       )
     )
     )
 )
 (if entn
   (progn
   (setq len(length entn)
  i 0)
   (repeat len
     (entdel (nth i entn))
     (setq i (1+ i))
     )
   )
   )
 (setq ok "YES")
 (while (= ok "YES")
   (setq ent
   (entsel
     "\nChon Text de thay gia tri dien tich :  "
   )
   )
   (if	(not ent)
     (progn
(setq err (getvar "errno"))
(if (= err 52)
  (setq ok "NO" ans "D")
)
     )
     (progn
     (if (= (cdr(assoc 0 (entget(car ent)))) "TEXT")
(setq te (car ent) ok "NO" ans "T"))
	)
   )
 )
 (if (or (= ans "d") (= ans "D"))
   (progn
     (setq po (getpoint "\n Chon diem chen de ghi dien tich :"))
     (setq cao (getdist "\n Nhap chieu cao chu : "))
     (wtxt (rtos S 2 2) po 0 cao)

   )
 )
 (if (or (= ans "t") (= ans "T"))
   (progn
     (setq ente (entget te))
     (setq ente (subst (cons 1 (rtos S 2 2)) (assoc 1 ente) ente))
     (entmod ente)

   )
 )
 (setvar "DimZin" oldim)
 (Princ)
)
				;
				;
				;
(defun wtxt (txt p ang h / sty)
 (setq sty (getvar "textstyle"))
 (entmake (list (cons 0 "TEXT")
	 (cons 7 sty)
	 (cons 1 txt)
	 (cons 10 p)
	 (cons 11 p)
	 (cons 72 2)
	 (cons 73 2)
	 (cons 50 ang)
	 (cons 40 h)
	 (cons 41 0.8)
   )
 )
)

 

 

Mình cảm ơn bạn đã quan tâm, lisp chạy rất tốt nhưng mình làm phiền bạn tý nữa nha, cố gắng giúp mình

1. Mình không muốn khi chạy có cái đuôi lòng thòng phía sau:

Command: ttdt

Unknown command "TTDT". Press F1 for help.

Unknown command "TTDT". Press F1 for help.

2. Vấn đề này mình đang đau đầu không biết giải quyết ra sau, mình muốn bạn chỉnh lại dùm mình khi diện tích được tính ra là một giá trị thực tế (cụ thể như: một mảnh đất với KT: 100x100 = 10.000m2, còn với lisp này thì giá trị được tính là 100m2 với tỷ lệ vẽ 1/10). Bạn có thể thêm chuỗi S= trước giá trị d/t và thêm cuỗi m2 (mét vuông) sau giá trị d/t và gán text là Vni-Helve, còn những cái khác vẫn giữ nguyên.

Nếu được bạn bớt chút thời gian giúp mình, cảm ơn bạn nhiều.

tomboy có thể giúp mình vấn đề đã nêu ở trên không? Cảm ơn bạn

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào Hoan, làm gì mà yêu cầu "được kết quả nhanh nhất" dữ quá, làm cho Thiep cũng không kịp hoàn thiện Lisp đúng cho mọi trường hợp. Xin hỏi Hoan đang thiết kế vét bùn cái gì mà gấp thế? Thôi thì Hoan tạm sử dụng lisp này vậy:

;;;---------------------------------
;;; LISP vet bun, COPYRIGHT BY THIEP
;;; FREE FROM CADVIET.COM-----------
(defun GiaoDT (e1 e2 / ob1 ob2 g L n kq)
 (setq	ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2)
g   (vlax-variant-value
      (vla-IntersectWith ob1 ob2 acExtendnone)
    )
 )
 (if (/= (vlax-safearray-get-u-bound g 1) -1)
   (setq L (vlax-safearray->list g))
 )
 (setq n 0)
 (repeat (/ (length L) 3)
   (setq kq
   (append (list (list (nth n L) (nth (+ n 1) L) (nth (+ n 2) L)))
	   kq
   )
   )
   (setq n (+ n 3))
 )
 kq
)
(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 SS-enlst (ss / c L)
 (setq c -1)
 (repeat (sslength ss)
   (setq L (cons (ssname ss (setq c (1+ c))) L))
 )
 (reverse L)
)
;;;----------------------
(defun taoRay (ModelS poR1 poR2)
 (vla-Addray
   ModelS
   (vlax-3d-point poR1)
   (vlax-3d-point poR2)
 )
)

;-----------------------
(defun TextTaluy (model k po h ang / objT)
 (setq	obj (vla-AddText
      *Model*
      (strcat "1:" (rtos k 2 1))
      (vlax-3d-point po)
      h
    )
 )
 (vla-put-Alignment obj acAlignmentTopCenter)
 (vla-put-TextAlignmentPoint obj (vlax-3d-point po))
 (vla-put-Rotation obj ang)
 (vla-put-layer obj "naovet")
)
;;;---------------------
(defun SAVE_MODE ()

 (command "Undo" "begin")
 (command "UCS" "W" "")
 (setq	OLD_OSMODE    (getvar "OSMODE")
OLD_CECOLOR   (getvar "CECOLOR")
OLD_AUTOSNAP  (getvar "AUTOSNAP")
OLD_ORTHOMODE (getvar "ORTHOMODE")
 )
 (setvar "cmdecho" 0)

)
(defun RESTORE ()
 (command "Undo" "end")
 (setvar "osmode" OLD_OSMODE)
 (setvar "AUTOSNAP" OLD_AUTOSNAP)
 (setvar "ORTHOMODE" OLD_ORTHOMODE)
 (setvar "CECOLOR" OLD_CECOLOR)
 (setvar "cmdecho" 1)
)
(vl-load-com)
;;;-----------------ham dinh thong so k_Thiep, d_Thiep, hei_Thiep
(defun c:khd ()
 (setq	k_Thiep	(cond (k_Thiep)
	      (5)
	)
 )
 (setq oldk_Thiep k_Thiep)
 (setq	k_Thiep	(getreal (strcat "\nChon goc doc nao vet (mau so) <"
			 (rtos oldk_Thiep 2 1)
			 "> : "

		 )
	)
 )
 (if (null k_Thiep)
   (setq k_Thiep oldk_Thiep)
 )
 (setq	d_Thiep	(cond (d_Thiep)
	      (5)
	)
 )
 (setq oldd_Thiep d_Thiep)
 (setq	d_Thiep	(getreal (strcat "\nChieu sau nao vet <"
			 (rtos oldd_Thiep 2 1)
			 "> : "

		 )
	)
 )
 (if (null d_Thiep)
   (setq d_Thiep oldd_Thiep)
 )
 (setq	hei_Thiep (cond	(hei_Thiep)
		(5)
	  )
 )
 (setq oldhei_Thiep hei_Thiep)
 (setq	hei_Thiep (getreal (strcat "\nChon chieu cao chu <"
			   (rtos oldhei_Thiep 2 1)
			   "> : "

		   )
	  )
 )
 (if (null hei_Thiep)
   (setq hei_Thiep oldhei_Thiep)
 )
 (princ)
 (print "Bay gio ban co the su dung lisp vbu.lsp")
)
;;;================================MAIN=============================
(DEFUN c:vbu (/	ActDoc *Model*	     *layer*	   en	  ss	 p1
	Pa     Pb     p1     p11    p2	   p21	  p3	 p4
	objD   enD    objR1  objR2  enR1   enR2	  pin1	 pin2
	pe1    pe2    objL2  objL1  enL1   enL2	  lay	 an1
	an2    pTex1  pTex2  i	    ss	   Len	  lop	 upp
       )
 (setq	ActDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
*Model*	(vla-get-ModelSpace ActDoc)
*layer*	(vla-get-Layers ActDoc)
 )
 (vla-StartUndoMark ActDoc)
 (SAVE_MODE)
 (if (not (tblsearch "layer" "naovet"))
   (progn
     (setq lay (vla-add *layer* "naovet"))
     (vla-put-color lay acRed)
   )
 )
 (princ "Chon cac curve be mat nao vet: ")
 (setq SS (ssget '((0 . "LWPOLYLINE"))))
 (setq Len (SS-enlst ss)
i 1)
 (foreach en Len
   (setq OBcur (vlax-ename->vla-object en))
   (vla-getboundingbox OBcur 'minpoint 'maxpoint)
   (setq lop	(vlax-safearray->list minpoint)
  upp	(vlax-safearray->list maxpoint)
  un (getvar "viewsize")
  ofp (list (/ (+ (car upp) (car lop)) 2) (- (cadr lop) un) 0.0)
   )
   (vla-zoomwindow
     (vlax-get-acad-object)
     (vlax-3d-point lop)
     (vlax-3d-point upp)
   )
   (redraw en 3)
   (setvar "osmode" 512)
   (if	(null k_Thiep)
(setq k_Thiep (getreal "\nChon goc doc nao vet (mau so): "))
   )
   (if	(null d_Thiep)
(setq d_Thiep	(getreal "\nChieu sau nao vet: "))
   )
   (if	(null hei_Thiep)
     (setq hei_Thiep (getreal "\nChon chieu cao chu: "))
   )
   (setq p1  (getpoint	(strcat	"\nChon mep nao vet ben TRAI cua mat cat so "
			(itoa i)
			":"
		)
      )
  p2  (getpoint
	(strcat "\nChon mep nao vet ben PHAI cua mat cat so " (itoa i) ":")
      )
  p11 (list (+ (car p1) k_Thiep) (- (cadr p1) 1) 0.0)
  p21 (list (- (car p2) k_Thiep) (- (cadr p2) 1) 0.0)
  an1 (angle p1 p11)
  an2 (angle p2 p21)
   )
   ;;;================
   (vl-cmdf ".offset" d_Thiep en ofp "")
   (setq enD (entlast))
   (setq objR1	(taoRay *Model* p1 p11)
  objR2	(taoRay *Model* p2 p21)
   )
   (setq enR1 (vlax-vla-object->ename objR1)
  enR2 (vlax-vla-object->ename objR2)
   )
   (setq PA (vlax-curve-getStartPoint enD)
  PB (vlax-curve-getEndPoint enD)
   )
   (setq pin1	(car (giaoDT enR1 enD))
  p11	(car (giaoDT enR1 en))
  pin2	(car (giaoDT enR2 enD))
  p22	(car (giaoDT enR2 en))
  pinR (car (giaoDT enR1 enR2))
   )
   (cond ((/= p1 p11)
   (setq p1 p11)
  )
  ((/= p2 p22)
   (setq p2 p22)
  )
   )
   (setvar "osmode" 0)
   (if	(< (car pin1) (car pin2))
     (Progn
(vla-delete objR1)
(vla-delete objR2)
(if (< (car PA) (car PB))
  (progn
    (VL-CMDF "_.break" enD pin2 pin2)
    (setq ss (ssname (ssget pin2) 0))
    (entdel ss)
    (setq pe1 (list (+ (car pin1) 0.1) (+ (cadr pin1) 0.1) 0.0)
	  pe2 (list (+ (car pin1) 0.1) (- (cadr pin1) 0.1) 0.0)
	  pe3 (list (- (car pin1) 0.1) (+ (cadr pin1) 0.1) 0.0)
	  pe4 (list (- (car pin1) 0.1) (- (cadr pin1) 0.1) 0.0)
    )
    (setq enD (ssname (ssget pin1) 0))
    (VL-CMDF "_.break" enD pin1 pin1)
    (entdel (ssname (ssget "F" (list pe3 pe4)) 0))
    (setq enD (ssname (ssget "F" (list pe1 pe2)) 0))
  )
  (progn
    (VL-CMDF "_.break" enD pin1 pin1)
    (setq ss (ssname (ssget pin1) 0))
    (entdel ss)
    (setq pe1 (list (+ (car pin2) 0.1) (+ (cadr pin2) 0.1) 0.0)
	  pe2 (list (+ (car pin2) 0.1) (- (cadr pin2) 0.1) 0.0)
	  pe3 (list (- (car pin2) 0.1) (+ (cadr pin2) 0.1) 0.0)
	  pe4 (list (- (car pin2) 0.1) (- (cadr pin2) 0.1) 0.0)
    )
    (setq enD (ssname (ssget pin2) 0))
    (VL-CMDF "_.break" enD pin2 pin2)
    (entdel (ssname (ssget "F" (list pe1 pe2)) 0))
    (setq enD (ssname (ssget "F" (list pe3 pe4)) 0))
  )
);;;end if trong
(setq Lp (list (car p1)
	       (cadr p1)
	       (car pin1)
	       (cadr pin1)
	 )
      objL1 (LWP Lp *Model*)
      enL1  (vlax-vla-object->ename objL1)
)
(setq Lp (list (car p2)
	       (cadr p2)
	       (car pin2)
	       (cadr pin2)
	 )
      objL2 (LWP Lp *Model*)
      enL2  (vlax-vla-object->ename objL2)
)
(vl-cmdf ".pedit" "m" enL1 end enL2 "" "j" "" "")
(setq lineNV (vlax-ename->vla-object (entlast)))
     );;;end progn 1
     (Progn
(vla-delete objR1)
(vla-delete objR2)
(entdel enD)
(setq Lp (list (car p1)
	       (cadr p1)
	       (car pinR)
	       (cadr pinR)
	       (car p2)
	       (cadr p2)
	 )
)
(setq lineNV (LWP Lp *Model*))
(setq pin1 pinR pin2 pinR)
     );;;end progn 2
   );;;end if ngoai
(vla-put-layer lineNV "naovet")
(vla-put-color lineNV acbylayer)
;;;---tao text----
(setq pTex1 (polar (acet-geom-midpoint p1 pin1)
		    (- an1 (/ pi 2))
		    (/ hei_Thiep 2)
	     )
)
(TextTaluy *Model* k_Thiep pTex1 hei_Thiep an1)
(setq pTex2 (polar (acet-geom-midpoint p2 pin2)
		    (+ an2 (/ pi 2))
		    (/ hei_Thiep 2)
	     )
)
(TextTaluy *Model* k_Thiep pTex2 hei_Thiep (+ an2 pi))
   (setq i (1+ i))
   (vla-ZoomExtents (vlax-get-acad-object))
   ;(redraw en 4)
 );;;end foreach
 (RESTORE)
 (vla-EndUndoMark ActDoc)
 (princ "\nChuc cac ban thanh cong. Thiep")
 (princ)
)

Hoan chú ý:

- Lisp sẽ hỏi các thông số 1 lần đầu tiên thôi, lần sau sẽ không hỏi nữa cho dù phát lệnh VBU đến lần thứ n. Muốn thay đổi các thông số này phải phát lệnh KHD trước khi phát lệnh VBU.

:bigsmile:

Chào anh Thiệp!

Lisp này khi conghoan dùng gặp phải vấn đề như thế này Thiệp xem lại giúp mình với!

1. Khi mình chọn mép nạo vét thì mình cần dùng truy bắt điểm là hai đường giao nhau (intersection), vì mình có đường trồng cỏ là đường giới hạn mà lisp thì chỉ có Nearest. nếu mình truy bwts điểm bằng ntersection thì sẽ bị lỗi.

2.Khi chọn đường tự nhiên thì mình chọn xong rồi ENTER, thay vì như thế Thiệp đổi lại bằng cách pick chọn rồi tự tiếp tục chọn hai điiểm giới hạn vét mà không cần ENTER.

3. Thường thì mái dốc vét hai bên bằng nhau nhưng cũng có trường hợp hai bên khác nhau Thiệp thêm vào với nhé.

4. Mình thấy mỗi lần chọn mặt cắt thì nó zoom all, có lẽ ý của Thiep để như vậy dễ nhìn nhưng mình thấy cũng không tiện lắm có thể bỏ cái này đi.

PS: hôm trước mình nghe nói Thiep sắp đi Lào vậy có đi không thế? Mình đang làm đường vào Cảng Cái Mép-Thị Vải ở dưới Bà Rịa. Công trình này đã nạo vét xong rồi, nhưng ngành mình làm công việc này nhiều lắm nên mình muốn tìm một cái lisp nào nhanh nhất để thực hiện thôi. Mình đưa ra ý tưởng như thế này Thiệp xem thử có khả thi không nhé: trên mỗi mặt cắt mình để lại hai layer (tự nhiên và giới hạn vét) , layer tự nhiên là polyline còn layer giới hạn là line, mục đích là khi mình chọn các đường tự nhiên thì mình dung thuộc tính polyline thì nó sẽ không chọn những đường giới hạn. Còn phạm vi vét là từ điểm giao giữa đường tự nhiên và đường giới hạn vét. đây là ý tưởng của mình mong được Thiep và anh em diễn đàn giúp đỡ. file cad: http://www.cadviet.com/upfiles/2/tnct_2.dwg

Mình cảm ơn anh em diễn đàn nhiều! Chúc anh em sức khoẻ và cuối tuần vui vẽ!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
svba1608    624

Một lần nữa nhờ mọi người viết hộ em 1 lisp. Tên lisp có thể mô tả là: thay đổi (hoặc nhập) số thứ tự theo sự chỉ định của chuột. Nghĩa là em có một bản vẽ có nhiều số, các số đặt lung tung, không theo trình tự nào cả. Bây giờ em muốn có 1 lisp như sau:

+ Nhập lệnh.

+ Nhập số bắt đầu (từ bàn phím), ví dụ số 25.

+ Nhập khoảng cách (độ tăng, giảm), ví dụ 1.

+ Dùng chuột pick vào 1 text bất kỳ, text đó biến thành số 25.

+ Pick vào text thứ 2, text đó thành số 26, text thứ 3 sẽ là 27…

Rất mong nhận được sự giúp đỡ. Cảm ơn!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Thaistreetz    515
Một lần nữa nhờ mọi người viết hộ em 1 lisp. Tên lisp có thể mô tả là: thay đổi (hoặc nhập) số thứ tự theo sự chỉ định của chuột. Nghĩa là em có một bản vẽ có nhiều số, các số đặt lung tung, không theo trình tự nào cả. Bây giờ em muốn có 1 lisp như sau:

+ Nhập lệnh.

+ Nhập số bắt đầu (từ bàn phím), ví dụ số 25.

+ Nhập khoảng cách (độ tăng, giảm), ví dụ 1.

+ Dùng chuột pick vào 1 text bất kỳ, text đó biến thành số 25.

+ Pick vào text thứ 2, text đó thành số 26, text thứ 3 sẽ là 27…

Rất mong nhận được sự giúp đỡ. Cảm ơn!

 

(defun C:sst ()
(setvar "cmdecho" 0)
(command "undo" "Begin" "")

(if (not i) (setq i 1))
(if (not a) (setq a 1))
(setq	i1 (getreal (strcat"\nSTT Ðâu Tiên < " (rtos i 2 0) " >: "))
a1 (getreal (strcat"\nSo gia < " (rtos a 2 0) " >: " 	)))
(if i1 (setq i i1))
(if a1 (setq a a1))
(while 
(progn
(setq res (entsel (strcat "\nChon text de ghi STT thu " (rtos i 2 0) "")))
(setq res (entget (car res)))
(setq res (subst (cons 1 (rtos i 2 0)) (assoc 1 res) res))
(entmod res)
(setq i (+ i a))
);progn
);while
(command "undo" "end" "")
(setvar "cmdecho" 1)
);end

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Tue_NV    3.841
Một lần nữa nhờ mọi người viết hộ em 1 lisp. Tên lisp có thể mô tả là: thay đổi (hoặc nhập) số thứ tự theo sự chỉ định của chuột. Nghĩa là em có một bản vẽ có nhiều số, các số đặt lung tung, không theo trình tự nào cả. Bây giờ em muốn có 1 lisp như sau:

+ Nhập lệnh.

+ Nhập số bắt đầu (từ bàn phím), ví dụ số 25.

+ Nhập khoảng cách (độ tăng, giảm), ví dụ 1.

+ Dùng chuột pick vào 1 text bất kỳ, text đó biến thành số 25.

+ Pick vào text thứ 2, text đó thành số 26, text thứ 3 sẽ là 27…

Rất mong nhận được sự giúp đỡ. Cảm ơn!

Em sử dụng đoạn code này thử xem nhé :

(defun c:dstt(/ so oldim delta dt ent)
;copyright by Tue_NV
(setq oldim (getvar "Dimzin"))
(setvar "Dimzin" 0)
(initget 1)
(setq so (getreal "\n Nhap so bat dau :"))
(initget 1)
(setq delta (getreal "\gia so  : "))
(initget 5)
(setq tp (getint "\n So chu so thap phan : "))

(while (setq dt (entsel "\n Chon so can thay doi : "))
(setq ent (entget(car dt)))
(setq ent (entmod (subst (cons 1 (rtos so 2 tp)) (assoc 1 ent) ent)))
(setq so (+ so delta))
)
(setvar "Dimzin" oldim)
(princ)
)

  • Vote tăng 3

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
tomboy    20
tomboy có thể giúp mình vấn đề đã nêu ở trên không? Cảm ơn bạn

OK, mình rất sẵn sàng,

Link của bạn đây: http://www.cadviet.com/upfiles/2/gdt.rar

down về chạy thử rồi cho nhận xét nhé!

Xin lỗi Hoángon614 nhé, tại mình chưa test kỹ nên không thể tránh khỏi sai sót, đây là Link mà mình đã sửa chữa.

Link vá lỗi đây: http://www.cadviet.com/upfiles/2/gdt_2.rar

Note: diện tích tính được trong acad phụ thuộc vào đơn vị vẽ, nếu người vẽ đơn vị là m thì diện tích là m2, còn nếu vẽ đơn vị là cm thì diện tích là cm2. Do vậy bạn đừng lo là chương trình tính sai, trong chuơng trình mình cũng hỗ trợ cả tỉ lệ diện tích nữa đấy, trong lúc tính diện tích bạn đáp lệnh O thì nó sẽ ra hộp thoại để cho bạn sửa lại tỉ lệ điện tích cũng như các yếu tố phụ trợ khác.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
HoangSon614    66
OK, mình rất sẵn sàng,

Link của bạn đây: http://www.cadviet.com/upfiles/2/gdt.rar

down về chạy thử rồi cho nhận xét nhé!

Cảm ơn bạn đã quan tâm, nhưng vẫn mắc một số lỗi. Bạn có thể xem lại giúp mình, cụ thể như:

1. Không đọc được tiếng việt của box

2. Khi nhập chiều cao chữ thoát luôn và báo lỗi

3. Diện tích thể hiện tại dòng command không chính xác (mình có khu đất 1000m2, vẽ tl 1/10 nhưng kết quả là: 100.000m2, tăng gấp 100 lần)

Command: gdt

 

Pick diem vao mien de lay dien tich : S=100000m2

Pick diem vao mien de lay dien tich :

 

Chon Text de thay gia tri dien tich or [Option]:

Chon diem chen de ghi dien tich :

Nhap chieu cao chu :<2.5>

Unknown command "J". Press F1 for help.

Unknown command "MC". Press F1 for help.

2.500000

 

Unknown command "GDT". Press F1 for help.

0

Unknown command "S=100000M2". Press F1 for help.

Unknown command "GDT". Press F1 for help.

nil

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
bonchen    0

Các anh viết dùm em 1 lisp,em cám ơn trước..^^..

Trên cad em có nhiều text (vd:1,2,3,4,…..a,b,c,d,e….v.v.) em muốn nối các text đó bằng đường line,em có kiếm các lisp có liên quan rùi nhưng ko đúng với ý em…ý em muốn lisp như sau:

+tại dòng command: noitext (em vd)

+nhap cac diem can noi:1,2,3,4,a,d

Enter (thì 1 nối 2, 2 nối 3, 3 nối 4, 4 nối a, a nối d,nhưng d thì ko được nối lại điểm 1)

Enter xong thi trở lại

+nhap cac diem can noi:

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Thaistreetz    515
Các anh viết dùm em 1 lisp,em cám ơn trước..^^..

Trên cad em có nhiều text (vd:1,2,3,4,…..a,b,c,d,e….v.v.) em muốn nối các text đó bằng đường line,em có kiếm các lisp có liên quan rùi nhưng ko đúng với ý em…ý em muốn lisp như sau:

+tại dòng command: noitext (em vd)

+nhap cac diem can noi:1,2,3,4,a,d

Enter (thì 1 nối 2, 2 nối 3, 3 nối 4, 4 nối a, a nối d,nhưng d thì ko được nối lại điểm 1)

Enter xong thi trở lại

+nhap cac diem can noi:

 

Thế này thì có khác gì so với việc bạn vẽ theo cách thông thường nhỉ?

gõ L -> enter -> bắt điểm vào 1 -> bắt điểm vào 2 ->...-> bắt điểm vào d -> ok

chẳng khác tý nào cả

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
matran    3
Thế này thì có khác gì so với việc bạn vẽ theo cách thông thường nhỉ?

gõ L -> enter -> bắt điểm vào 1 -> bắt điểm vào 2 ->...-> bắt điểm vào d -> ok

chẳng khác tý nào cả

ý bạn ấy kg muốn dùng chuột (zôm pan chi cho mệt), chỉ dùng bàn phím đánh số trên dòng command đấy mà.

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
tomboy    20
Cảm ơn bạn đã quan tâm, nhưng vẫn mắc một số lỗi. Bạn có thể xem lại giúp mình, cụ thể như:

1. Không đọc được tiếng việt của box

2. Khi nhập chiều cao chữ thoát luôn và báo lỗi

3. Diện tích thể hiện tại dòng command không chính xác (mình có khu đất 1000m2, vẽ tl 1/10 nhưng kết quả là: 100.000m2, tăng gấp 100 lần)

Command: gdt

 

Pick diem vao mien de lay dien tich : S=100000m2

Pick diem vao mien de lay dien tich :

 

Chon Text de thay gia tri dien tich or [Option]:

Chon diem chen de ghi dien tich :

Nhap chieu cao chu :<2.5>

Unknown command "J". Press F1 for help.

Unknown command "MC". Press F1 for help.

2.500000

 

Unknown command "GDT". Press F1 for help.

0

Unknown command "S=100000M2". Press F1 for help.

Unknown command "GDT". Press F1 for help.

nil

Mình sửa lại cho bạn rồi, thông cảm nhé tại mình chưa test kỹ,

link nè: http://www.cadviet.com/upfiles/2/gdt_2.rar (bản vá lỗi mới nhất đó)

Note: nếu bản vẽ tỉ tệ 1/10 thì trong Option của lệnh GDT phần tỉ lệ đo vẽ bạn nhập số 10 vào nhé!

Sory: link vá lỗi này nhé http://www.cadviet.com/upfiles/2/gdt_1.rar

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thiep    263
Chào anh Thiệp!

Lisp này khi conghoan dùng gặp phải vấn đề như thế này Thiệp xem lại giúp mình với!

1. Khi mình chọn mép nạo vét thì mình cần dùng truy bắt điểm là hai đường giao nhau (intersection), vì mình có đường trồng cỏ là đường giới hạn mà lisp thì chỉ có Nearest. nếu mình truy bwts điểm bằng ntersection thì sẽ bị lỗi.

2.Khi chọn đường tự nhiên thì mình chọn xong rồi ENTER, thay vì như thế Thiệp đổi lại bằng cách pick chọn rồi tự tiếp tục chọn hai điiểm giới hạn vét mà không cần ENTER.

3. Thường thì mái dốc vét hai bên bằng nhau nhưng cũng có trường hợp hai bên khác nhau Thiệp thêm vào với nhé.

4. Mình thấy mỗi lần chọn mặt cắt thì nó zoom all, có lẽ ý của Thiep để như vậy dễ nhìn nhưng mình thấy cũng không tiện lắm có thể bỏ cái này đi.

PS: hôm trước mình nghe nói Thiep sắp đi Lào vậy có đi không thế? Mình đang làm đường vào Cảng Cái Mép-Thị Vải ở dưới Bà Rịa. Công trình này đã nạo vét xong rồi, nhưng ngành mình làm công việc này nhiều lắm nên mình muốn tìm một cái lisp nào nhanh nhất để thực hiện thôi. Mình đưa ra ý tưởng như thế này Thiệp xem thử có khả thi không nhé: trên mỗi mặt cắt mình để lại hai layer (tự nhiên và giới hạn vét) , layer tự nhiên là polyline còn layer giới hạn là line, mục đích là khi mình chọn các đường tự nhiên thì mình dung thuộc tính polyline thì nó sẽ không chọn những đường giới hạn. Còn phạm vi vét là từ điểm giao giữa đường tự nhiên và đường giới hạn vét. đây là ý tưởng của mình mong được Thiep và anh em diễn đàn giúp đỡ. file cad: http://www.cadviet.com/upfiles/2/tnct_2.dwg

Mình cảm ơn anh em diễn đàn nhiều! Chúc anh em sức khoẻ và cuối tuần vui vẽ!

Gởi Hoan, theo đề nghị của Hoan, các mục 1, 2, 3, 4 Thiep sẽ chỉnh lại nhanh chóng. Còn ý tưởng mới của Hoan Thiep chưa hiểu lắm. Có phải Hoan nói nạo vét không phải offset từ mặt cắt tự nhiên xuống n mét, mà nạo vét xuống tới cots tuyệt đối nào đó không? Các luồng sông biển bên Hàng Hải cũng làm vậy và có một sai số nạo vét nữa. Hoan cứ đưa lên 1 bản vẽ ví dụ xem.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
tomboy    20
Các anh viết dùm em 1 lisp,em cám ơn trước..^^..

Trên cad em có nhiều text (vd:1,2,3,4,…..a,b,c,d,e….v.v.) em muốn nối các text đó bằng đường line,em có kiếm các lisp có liên quan rùi nhưng ko đúng với ý em…ý em muốn lisp như sau:

+tại dòng command: noitext (em vd)

+nhap cac diem can noi:1,2,3,4,a,d

Enter (thì 1 nối 2, 2 nối 3, 3 nối 4, 4 nối a, a nối d,nhưng d thì ko được nối lại điểm 1)

Enter xong thi trở lại

+nhap cac diem can noi:

bạn sử dụng link này: http://www.cadviet.com/upfiles/2/noi.rar

Lệnh là NOI,

Command: Hay chon cac diem mia can noi, sau cung nhan Enter or [undo]:...

Bạn chỉ chuột vào điểm mia cần nối, hoặc đánh tên điểm cho nó tự nối. Nếu điểm nó không tìm thấy trong vùng chọn thì nó sẽ yêu cầu bạn chọn vùng chọn mới : Select objects:

Nếu bạn muốn nối 1 điểm với 1 đoạn thẳng thì bạn hãy đè phím Shifp + chuột phải, có 1 menu truy bắt điểm hiện ra để cho bạn chọn lụa, khi chọn lựa xong bạn chỉ chuột vào đoạn thẳng cần nối thì nó sẽ nối, nếu bạn bỏ chọn Shift+chuột phải thì nó sẽ tự động chuyển layer sang layer của đối tượng bạn vừa chọn

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
tomboy    20
Thế này thì có khác gì so với việc bạn vẽ theo cách thông thường nhỉ?

gõ L -> enter -> bắt điểm vào 1 -> bắt điểm vào 2 ->...-> bắt điểm vào d -> ok

chẳng khác tý nào cả

khi bạn nối 2 text lại với nhau bằng lệnh Line thì nó sẽ bị sai, tại vì khi bạn dùng lệnh PROPERTIES để thay đổi góc quay của chữ hoặc thay đổi chiều cao chữ hoặc 1 vài thuộc tính khác của chữ (nhưng không được thay đổi vị trí của chữ), thì sau đó bạn sử dụng lệnh LINE để nối 2 text đó lại với nhau thì đường thẳng vừa nối nó sẽ không trùng với đường thẳng đã nối trước khi text thay đổi. Điều này rất quan trọng tại vì khi bạn vẽ 1 cái ao bằng cách nối các điểm mia đo được lại với nhau bằng lệnh LINE thì diện tích cái ao đó sẽ bị sai, và mỗi khi bạn thay đổi tỉ lệ bản vẽ thì các text trong bản vẽ cũng thay đổi theo vì thế mà cái ao vừa vẽ được sẽ không nằm đúng vị trí của các điểm mia đó nữa.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
svba1608    624
(defun C:sst ()

(setvar "cmdecho" 0)

(command "undo" "Begin" "")

Em sử dụng đoạn code này thử xem nhé :

Rất cảm ơn sự giúp đỡ của anh Thaistreetz và anh Tue_NV. Sau khi sử dụng cả 2 lisp em có nhận xét như sau:

+ Lisp sst của anh Thaistreetz: đơn giản, dễ sử dụng hơn. Nhưng anh để chữ có dấu nên dễ bị lỗi font. Có một nhược điểm nhỏ là chỉ có thể tăng giảm giá trị với số gia là số nguyên, còn với giá trị số thập phân thì không sử dụng được. Nhưng có một ưu điểm tuyệt vời là: có khả năng “nhớ” (lưu giữ) giá trị cuối cùng lần trước.

+ Lisp dstt của anh Tue_NV: Lisp này thực sự thể hiện đẳng cấp của một người viết lisp chuyên nghiệp. Lisp của anh cụ thể, rõ rang, lường mọi tình huống xảy ra, hơn cả yêu cầu của em. Nếu tích hợp được them khả năng “nhớ” số như ở lisp sst của anh Thaistreetz thì càng tuyệt vời hơn.

Chân thành cảm ơn các anh!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
gia_bach    1.442
Trên cad em có nhiều text (vd:1,2,3,4,…..a,b,c,d,e….v.v.) em muốn nối các text đó bằng đường line,em có kiếm các lisp có liên quan rùi nhưng ko đúng với ý em…ý em muốn lisp như sau:

+tại dòng command: noitext (em vd)

+nhap cac diem can noi:1,2,3,4,a,d

Enter (thì 1 nối 2, 2 nối 3, 3 nối 4, 4 nối a, a nối d,nhưng d thì ko được nối lại điểm 1)

Enter xong thi trở lại

+nhap cac diem can noi:

Ý bạn là : Vẽ Line từ điểm chèn của Text 1 đến điểm chèn của Text 2 ?

 

khi bạn nối 2 text lại với nhau bằng lệnh Line thì nó sẽ bị sai,

..........

, thì sau đó bạn sử dụng lệnh LINE để nối 2 text đó lại với nhau

..........

Bạn cho hỏi : Cad có lệnh LINE để nối 2 text lại với nhau ?

Phiên bản CAD bao nhiêu vậy bạn ?

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Thaistreetz    515
Rất cảm ơn sự giúp đỡ của anh Thaistreetz và anh Tue_NV. Sau khi sử dụng cả 2 lisp em có nhận xét như sau:

+ Lisp sst của anh Thaistreetz: đơn giản, dễ sử dụng hơn. Nhưng anh để chữ có dấu nên dễ bị lỗi font. Có một nhược điểm nhỏ là chỉ có thể tăng giảm giá trị với số gia là số nguyên, còn với giá trị số thập phân thì không sử dụng được. Nhưng có một ưu điểm tuyệt vời là: có khả năng “nhớ” (lưu giữ) giá trị cuối cùng lần trước.

+ Lisp dstt của anh Tue_NV: Lisp này thực sự thể hiện đẳng cấp của một người viết lisp chuyên nghiệp. Lisp của anh cụ thể, rõ rang, lường mọi tình huống xảy ra, hơn cả yêu cầu của em. Nếu tích hợp được them khả năng “nhớ” số như ở lisp sst của anh Thaistreetz thì càng tuyệt vời hơn.

Chân thành cảm ơn các anh!

 

Mình đổi tên lệnh lại nhé, lisp trước mình gõ nhầm tên lệnh stt thành ra là sst nên khi sử dụng dễ gõ nhầm thành stt.

Code đã sửa lại. Nếu không nhập chữ số thập phân khi chương trình hỏi thì chương trình mặc định nó là 0 nhé.

(defun C:stt ()
(setvar "cmdecho" 0)
(command "undo" "begin")
(setq oldim (getvar "Dimzin"))
(setvar "Dimzin" 0)
(if (not i) (setq i 1))
(if (not a) (setq a 1))
(setq	i1 (getreal (strcat"\nNhap so bat dau < " (rtos i 2 0) " >: "))
a1 (getreal (strcat"\nSo gia < " (rtos a 2 0) " >: " )))
(if i1 (setq i i1))
(if a1 (setq a a1))
(if (not tp) (setq tp 0))
(setq tp1 (getint "\nSo chu so thap phan: "))
(if tp1 (setq tp tp1))
(while 
(setq res (entsel (strcat "\nChon text de ghi STT thu " (rtos i 2 tp) "")))
(setq res (entget (car res)))
(setq res (entmod (subst (cons 1 (rtos i 2 tp)) (assoc 1 res) res))
)
(setq i (+ i a))
);while
(setvar "Dimzin" oldim)
(command "undo" "end")
(setvar "cmdecho" 1)
);end

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác

Admin cho hoi post nhầm bài thì muốn xoá đi thì làm như thế nào, cái này mình post sao nó lên hai bài luôn, không biết cách xoá nên nhân tiện edit lại để hỏi luôn. Thank!

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Chào a Thiêp!

Thiệp hiểu sai ý của mình rồi, ý tưởng của mình cũng làm công tác nạo vét như cũ thôi, kết quả tạo thành cũng như thế không có gì khác nhưng mà trình tự thực hiện thì nhanh hơn. Nó như thế này:

Mình có rất nhiều mặt cắt ngang chi tiết, trên mỗi mặt cắt mình có 1 đường tự nhiên(polyline) và hai đường giới hạn vét (line), hai đường giới hạn vét cắt đường tự nhiên tại hai điểm ( tạm gọi là điểm A và điểm :bigsmile:. Sau khi chạy lisp, nhập chiều sâu vét, mái dốc bên trái, bên phải (y như cũ), sau đó quét chọn tấc cả các mặt cắt (có cả đường tự nhiên và đường giới hạn vét). ứng với mỗi đường tự nhiên (polyline) và hai đường giới hạn vét thì lisp sẽ cho mình một đường nạo vét. Mình thấy đượn như thế này thì công tác nạo vét sẽ cực kỳ nhanh nhưng lại sợ ngoài khả năng của lisp. Chúc anh em diễn đàn một tuần làm việc vui vẽ!

Mình định up file lên mà up hoai chẳng được, Thiệp xem file cad hôm trứơc của Hoan cũng được, bên trái là phần trước khi chạy lisp, bên phải là phần sau khi chạy lisp.

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thiep    263

À, thiep thấy rồi, đường giới hạn nạo vét là 2 cái "râu cá trê" line màu vàng đặt trong lớp "giới hạn vét" phải không?

Thiep hỏi tiếp: đường nạo vét, Hoan có muốn là nét đứt màu tím không?

đường Cái Mép - Thị Vải hằng năm có bị bồi lắng hay sao mà phải nạo vét hả H?

Thiep mới ở CPC về hơn 10 ngày.

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
duytrung    2

Các bạn giúp mình sửa lại cái lisp chạy Trắc dọc cống .

*Hiện trạng:

Lisp này dùng để vẽ trắc dọc cống

-Sau khi nhập các số liệu thiết kế vào five của Excel sau đó save as chúng lại dưới dạng đuôi .prn

-Từ Autocad R14 AP lisp TDC2005-v9.lsp, nhập lệnh tdc rồi mở five vừa save thi => bve TDOC

(lisp này chạy được khi cad R14 có font ( Vn_vni.shx)

*Sửa chữa:

-Vì lisp này chỉ chạy ổn định trên cad R14 còn các CAD khác thì 1 là chạy không được ,2 là bị lỗi do đó nhờ các bạn trên diễn đàn CADViet chuyển giúp lisp này chạy trên Cad2007 và không phụ thuộc vào font trên .

Nếu lisp này hoàn thiện nó sẽ giúp ích rất nhiều cho các bạn làm bên mảng thoát nước .

-Rất mong được sự giúp đỡ của các anh em trên diễn đàn và sớm nhận được hồi âm.

Thân chào

Đây là five mình đã upload

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

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
thiep    263

Gửi Hoan, bây giờ thì Ý tưởng của Hoan đã được hoàn thiện bằng lisp sau đây. Khi chọn đối tượng, Hoan phải chọn cả đường địa hình tự nhiên và cả đường giới hạn cùng 1 lúc, cứ tiếp tục cho đến hết mặt cắt, enter kết thúc. :bigsmile:

;;;---------------------------------
;;; LISP vet bun, COPYRIGHT BY THIEP 0918841230
;;; FREE FROM CADVIET.COM-----------
(defun GiaoDT (e1 e2 / ob1 ob2 g L n kq)
 (setq	ob1 (vlax-ename->vla-object e1)
ob2 (vlax-ename->vla-object e2)
g   (vlax-variant-value
      (vla-IntersectWith ob1 ob2 acExtendnone)
    )
 )
 (if (/= (vlax-safearray-get-u-bound g 1) -1)
   (setq L (vlax-safearray->list g))
 )
 (setq n 0)
 (repeat (/ (length L) 3)
   (setq kq
   (append (list (list (nth n L) (nth (+ n 1) L) (nth (+ n 2) L)))
	   kq
   )
   )
   (setq n (+ n 3))
 )
 kq
)
(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 SS-enlst (ss / c L)
 (setq c -1)
 (repeat (sslength ss)
   (setq L (cons (ssname ss (setq c (1+ c))) L))
 )
 (reverse L)
)
;;;----------------------
(defun taoRay (ModelS poR1 poR2)
 (vla-Addray
   ModelS
   (vlax-3d-point poR1)
   (vlax-3d-point poR2)
 )
)

;-----------------------
(defun TextTaluy (model k po h ang / obj)
 (setq	obj (vla-AddText
      *Model*
      (strcat "1:" (rtos k 2 1))
      (vlax-3d-point po)
      h
    )
 )
 (vla-put-Alignment obj acAlignmentTopCenter)
 (vla-put-TextAlignmentPoint obj (vlax-3d-point po))
 (vla-put-Rotation obj ang)
 (vla-put-layer obj "vetbun")
)
;;;---------------------
(defun SAVE_MODE ()

 (command "Undo" "begin")
 (command "UCS" "W" "")
 (setq	OLD_OSMODE    (getvar "OSMODE")
OLD_CECOLOR   (getvar "CECOLOR")
OLD_AUTOSNAP  (getvar "AUTOSNAP")
OLD_ORTHOMODE (getvar "ORTHOMODE")
 )
 (setvar "cmdecho" 0)
 (setvar "plinegen" 1)

)
(defun RESTORE ()
 (command "Undo" "end")
 (setvar "osmode" OLD_OSMODE)
 (setvar "AUTOSNAP" OLD_AUTOSNAP)
 (setvar "ORTHOMODE" OLD_ORTHOMODE)
 (setvar "CECOLOR" OLD_CECOLOR)
 (setvar "cmdecho" 1)
)
;;;--------------------------
(defun DXF (code en) (cdr (assoc code (entget en))))
;;; -------------------------------
(defun existLinetype (doc LineTypeName / item loaded)
 (vlax-for item (vla-get-linetypes doc)
   (if (= (strcase (vla-get-name item)) (strcase LineTypeName))
     (setq loaded T)
   )
 )
)
;;;------loadLinetype
(defun loadLinetype (doc LineTypeName FileName)
 (if (and
       (not (existLinetype doc LineTypeName))
       (vl-catch-all-error-p
         (vl-catch-all-apply
           'vla-load
           (list
             (vla-get-Linetypes doc)
             LineTypeName
             FileName
           )
         )
       )
     )
   nil
   T
 )
)
;;;--------------------------
(vl-load-com)

;;;================================MAIN=============================
(DEFUN c:vbu (/	ActDoc *Model*	     *layer*	   en	  ss	 p1
	Pa     Pb     p1     p11    p2	   p21	  p3	 p4
	objD   enD    objR1  objR2  enR1   enR2	  pin1	 pin2
	pe1    pe2    objL2  objL1  enL1   enL2	  lay	 an1
	an2    pTex1  pTex2  i	    ss	   Len	  lop	 upp
	Lint   intP   enLWP
       )
 (setq	ActDoc	(vla-get-ActiveDocument (vlax-get-acad-object))
*Model*	(vla-get-ModelSpace ActDoc)
*layer*	(vla-get-Layers ActDoc)
 )
 (vla-StartUndoMark ActDoc)
 (SAVE_MODE)
 (loadLinetype ActDoc "HIDDEN" "acad.lin")
 (if (not (tblsearch "layer" "vetbun"))
   (progn
     (setq lay (vla-add *layer* "vetbun"))
     (vla-put-color lay acMagenta)
     (vla-put-Linetype lay "HIDDEN")
   )
 )
 (princ "Chon cac curve be mat nao vet: ")
 (While
   (setq SS (ssget '((0 . "LWPOLYLINE,LINE"))))
    (if (null k_Thiep1) (setq k_Thiep1 (getreal  "\nChon goc doc nao vet ben PHAI (mau so): ")))
    (if (null k_Thiep2) (setq k_Thiep2 (getreal  "\nChon goc doc nao vet ben TRAI (mau so): ")))
    (if (null d_Thiep) (setq d_Thiep (getreal  "\nChieu sau nao vet: ")))
    (if (null hei_Thiep) (setq hei_Thiep (getreal  "\nChon chieu cao chu: ")))
    (setq Len (SS-enlst ss)
   i   0
    )
    (foreach en Len
      (if (eq (dxf 0 en) "LWPOLYLINE")
 (progn
   (redraw en 3)
   (setq enLWP en
	 OBcur (vlax-ename->vla-object enLWP)
   )
   (vla-getboundingbox OBcur 'minpoint 'maxpoint)
   (setq lop (vlax-safearray->list minpoint)
	 upp (vlax-safearray->list maxpoint)
	 un  (getvar "viewsize")
	 ofp (list (/ (+ (car upp) (car lop)) 2)
		   (- (cadr lop) un)
		   0.0
	     )
   )
 )
      )				;end if
    )
    (foreach en Len
      (if (not (eq (dxf 0 en) "LWPOLYLINE"))
 (progn
   (setq intP (car (GiaoDT en enLWP)))
   (if intP
     (setq Lint (cons intP Lint))
   )
 )
      )
    )
    (setq Lint
    (vl-sort
      Lint
      '(lambda (e1 e2) (< (car e1) (car e2)))
    )
    )
    (setvar "osmode" 32)
    (setq p1  (car Lint)
   p2  (cadr Lint)
   p11 (list (+ (car p1) k_Thiep1) (- (cadr p1) 1) 0.0)
   p21 (list (- (car p2) k_Thiep2) (- (cadr p2) 1) 0.0)
   an1 (angle p1 p11)
   an2 (angle p2 p21)
    )
;;;================
    (vl-cmdf ".offset" d_Thiep enLWP ofp "")
    (setq enD (entlast))
    (setq objR1 (taoRay *Model* p1 p11)
   objR2 (taoRay *Model* p2 p21)
    )
    (setq enR1	(vlax-vla-object->ename objR1)
   enR2	(vlax-vla-object->ename objR2)
    )
    (setq PA (vlax-curve-getStartPoint enD)
   PB (vlax-curve-getEndPoint enD)
    )
    (setq pin1	(car (giaoDT enR1 enD))
   p11	(car (giaoDT enR1 enLWP))
   pin2	(car (giaoDT enR2 enD))
   p22	(car (giaoDT enR2 enLWP))
   pinR	(car (giaoDT enR1 enR2))
    )
    (cond ((/= p1 p11)
    (setq p1 p11)
   )
   ((/= p2 p22)
    (setq p2 p22)
   )
    )
    (setvar "osmode" 0)
    (if (< (car pin1) (car pin2))
      (Progn
 (vla-delete objR1)
 (vla-delete objR2)
 (if (< (car PA) (car PB))
   (progn
     (VL-CMDF "_.break" enD pin2 pin2)
     (setq ss (ssname (ssget pin2) 0))
     (entdel ss)
     (setq pe1 (list (+ (car pin1) 0.1) (+ (cadr pin1) 0.1) 0.0)
	   pe2 (list (+ (car pin1) 0.1) (- (cadr pin1) 0.1) 0.0)
	   pe3 (list (- (car pin1) 0.1) (+ (cadr pin1) 0.1) 0.0)
	   pe4 (list (- (car pin1) 0.1) (- (cadr pin1) 0.1) 0.0)
     )
     (setq enD (ssname (ssget pin1) 0))
     (VL-CMDF "_.break" enD pin1 pin1)
     (entdel (ssname (ssget "F" (list pe3 pe4)) 0))
     (setq enD (ssname (ssget "F" (list pe1 pe2)) 0))
   )
   (progn
     (VL-CMDF "_.break" enD pin1 pin1)
     (setq ss (ssname (ssget pin1) 0))
     (entdel ss)
     (setq pe1 (list (+ (car pin2) 0.1) (+ (cadr pin2) 0.1) 0.0)
	   pe2 (list (+ (car pin2) 0.1) (- (cadr pin2) 0.1) 0.0)
	   pe3 (list (- (car pin2) 0.1) (+ (cadr pin2) 0.1) 0.0)
	   pe4 (list (- (car pin2) 0.1) (- (cadr pin2) 0.1) 0.0)
     )
     (setq enD (ssname (ssget pin2) 0))
     (VL-CMDF "_.break" enD pin2 pin2)
     (entdel (ssname (ssget "F" (list pe1 pe2)) 0))
     (setq enD (ssname (ssget "F" (list pe3 pe4)) 0))
   )
 )
;;;end if trong
 (setq Lp    (list (car p1)
		   (cadr p1)
		   (car pin1)
		   (cadr pin1)
	     )
       objL1 (LWP Lp *Model*)
       enL1  (vlax-vla-object->ename objL1)
 )
 (setq Lp    (list (car p2)
		   (cadr p2)
		   (car pin2)
		   (cadr pin2)
	     )
       objL2 (LWP Lp *Model*)
       enL2  (vlax-vla-object->ename objL2)
 )
 (vl-cmdf ".pedit" "m" enL1 end enL2 "" "j" "" "")
 (setq lineNV (vlax-ename->vla-object (entlast)))
      )
;;;end progn 1
      (Progn
 (vla-delete objR1)
 (vla-delete objR2)
 (entdel enD)
 (setq Lp (list	(car p1)
		(cadr p1)
		(car pinR)
		(cadr pinR)
		(car p2)
		(cadr p2)
	  )
 )
 (setq lineNV (LWP Lp *Model*))
 (setq pin1 pinR
       pin2 pinR
 )
      )
;;;end progn 2
    )
;;;end if ngoai
    (vla-put-layer lineNV "vetbun")
    (vla-put-color lineNV acbylayer)
    (vla-put-LinetypeScale lineNV 2)
    (vla-put-LinetypeGeneration lineNV T)
;;;---tao text----
    (setq pTex1 (polar	(acet-geom-midpoint p1 pin1)
		(- an1 (/ pi 2))
		(/ hei_Thiep 2)
	 )
    )
    (TextTaluy *Model* k_Thiep1 pTex1 hei_Thiep an1)
    (setq pTex2 (polar	(acet-geom-midpoint p2 pin2)
		(+ an2 (/ pi 2))
		(/ hei_Thiep 2)
	 )
    )
    (TextTaluy *Model* k_Thiep2 pTex2 hei_Thiep (+ an2 pi))
    (setq Lint nil
   Len nil)

;(redraw en 4)
 )
;;;end while
 (vla-ZoomExtents (vlax-get-acad-object))
 (RESTORE)
 (vla-EndUndoMark ActDoc)
 (princ "\nChuc cac ban thanh cong. Thiep")
 (princ)
)
;;;-----------------ham dinh thong so k_Thiep, d_Thiep, hei_Thiep
(defun c:khd ()
 (setq	k_Thiep1	(cond (k_Thiep1)
	      (5)
	)
 )
 (setq oldk_Thiep1 k_Thiep1)
 (setq	k_Thiep1	(getreal (strcat "\nChon goc doc nao vet ben PHAI (mau so) <"
			 (rtos oldk_Thiep1 2 1)
			 "> : "

		 )
	)
 )
 (if (null k_Thiep1)
   (setq k_Thiep1 oldk_Thiep1)
 )
(setq	k_Thiep2	(cond (k_Thiep2)
	      (5)
	)
 )
 (setq oldk_Thiep2 k_Thiep2)
 (setq	k_Thiep2	(getreal (strcat "\nChon goc doc nao vet ben TRAI (mau so) <"
			 (rtos oldk_Thiep2 2 1)
			 "> : "

		 )
	)
 )
 (if (null k_Thiep2)
   (setq k_Thiep2 oldk_Thiep2)
 )



 (setq	d_Thiep	(cond (d_Thiep)
	      (5)
	)
 )
 (setq oldd_Thiep d_Thiep)
 (setq	d_Thiep	(getreal (strcat "\nChieu sau nao vet <"
			 (rtos oldd_Thiep 2 1)
			 "> : "

		 )
	)
 )
 (if (null d_Thiep)
   (setq d_Thiep oldd_Thiep)
 )
 (setq	hei_Thiep (cond	(hei_Thiep)
		(5)
	  )
 )
 (setq oldhei_Thiep hei_Thiep)
 (setq	hei_Thiep (getreal (strcat "\nChon chieu cao chu <"
			   (rtos oldhei_Thiep 2 1)
			   "> : "

		   )
	  )
 )
 (if (null hei_Thiep)
   (setq hei_Thiep oldhei_Thiep)
 )
 (prinC "\nBay gio ban co the su dung lisp vbu.lsp")
 (princ)
 (c:vbu)
)

  • Vote tăng 1

Chia sẻ bài đăng này


Liên kết tới bài đăng
Chia sẻ trên các trang web khác
Khách
Chủ đề này bây giờ đã bị đóng lại để trả lời thêm.

×