Đến nội dung


Hình ảnh
- - - - -

[Đã xong] Lisp thêm đỉnh cho PL


  • Please log in to reply
23 replies to this topic

#21 manhlong0x

manhlong0x

    biết pan

  • Members
  • Pip
  • 8 Bài viết
Điểm đánh giá: 0 (bình thường)

Đã gửi 08 June 2016 - 10:44 AM

chán ghê bây giò em muốn cát poline thành 2 đường tuỳ chọn .. các bác chỉ em phát .. em làm adv edv .. rùi vtx của các bác đều ko được và đều báo lỗi
  • 0

#22 phuhvp

phuhvp

    biết vẽ line

  • Members
  • PipPip
  • 24 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 08 June 2016 - 04:30 PM

Có 1 vấn đề hơi nhức nhối là lisp vtx của bác rất hay, mà cad 2005 dùng không đưoc ( đã có Expess cho cad2005), cad 2007 thì OK

 

Có Bác nào có cách khắc phục không ta, mò miết mà không tìm thấy nguyên nhân tại sao cad 2005 lại dùng không được


  • 0

#23 phuhvp

phuhvp

    biết vẽ line

  • Members
  • PipPip
  • 24 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 17 June 2016 - 11:46 AM

Đây rồi. Source nguồn của Gilles Chanteau, ket thêm tí muối,lisp áp dụng cho cả Pline có arc và Width thay đổi

Lệnh vtx.
Update :
Ấn u hoặc Ctrl Z để undo trong quá trình làm việc
Cảm ơn bác Thaistreetz ^^

(defun c:vtx () ;main

(vl-load-com)

(vl-cmdf "undo" "Begin")

(initget "t b T B")

(setq ans (getkword "Th\U+00EAm hay b\U+1EDBt vextex ? [T / B]"))

(cond ((or(= ans "t")(= ans "T")(not ans))(addvtx))

		(T (delvtx))

)

(vl-cmdf "undo" "end")

)



(defun addvtx	(/    err  AcDoc     pl	  ob   pk   pa	 ap   typ  org

		 ucs  ocs  pt	sp   ep	  co   no   p1	 p2   pt   ce

		 a1   a2   bu	pw   wi	  nw

		) 

  (setq	m:err	*error*

	*error*	err

	AcDoc	(vla-get-activeDocument (vlax-get-acad-object))

	os (getvar "osmode")

	 

  )  



  (while 

	(or(initget "u")

	(setq pl (entsel "\nCh\U+1ECDn ph\U+00E2n \U+0111o\U+1EA1n mu\U+1ED1n add th\U+00EAm vertex : ")))	 

	(cond  ((or(= pl "u")(= pl "U"))(vl-cmdf "undo" "back"))	

		   (T 

				(setq ob (vlax-ename->vla-object (car pl)))

				(setq typ (vla-get-Objectname ob))    

				(if	(or (= typ "AcDbPolyline")

					(and (member typ '("AcDb2dPolyline" "AcDb3dPolyline"))

					(= 0 (vla-get-Type ob))

					)

					)

					(progn

						(vl-cmdf "undo" "mark")

							(setq pk

							(if (= typ "AcDb3dPolyline")

								(trans (osnap (cadr pl) "_nea") 1 0)

								(vlax-curve-getClosestPointToProjection

								ob

		   (trans (cadr pl) 1 0)

		   (mapcar '-

			   (trans (getvar "VIEWDIR") 1 0)

			   (trans '(0 0 0) 1 0)

		   )

		 )

	       )

	)

	(setq ap (/ (* (getvar "APERTURE")

		       (getvar "VIEWSIZE")

		    )

		    (cadr (getvar "SCREENSIZE"))

		 )

	)

	(if (= typ "AcDbPolyline")

	  (setq co (split-list (vlax-get ob 'Coordinates) 2))

	  (setq co (split-list (vlax-get ob 'Coordinates) 3))

	)

	(cond

	  ((equal pk (vlax-curve-getStartPoint ob) ap)

	   (setq pa 0)

	   (if (= (vla-get-Closed ob) :vlax-false)

	     (setq sp (vlax-curve-getStartPoint ob)

		   ep nil

	     )

	     (setq ep nil

		   sp nil

	     )

	   )

	  )

	  ((equal pk (vlax-curve-getEndPoint ob) ap)

	   (setq pa (1- (length co)))

	   (if (= (vla-get-Closed ob) :vlax-false)

	     (setq ep (vlax-curve-getEndPoint ob)

		   sp nil

	     )

	     (setq ep nil

		   sp nil

	     )

	   )

	  )

	  (T

	   (setq pa (atoi (rtos (vlax-curve-getParamAtPoint ob pk) 2))

		 ep nil

		 sp nil

	   )

	  )

	)

	(if (and (/= typ "AcDb3dPolyline")

		 (or

		   (not	(equal (trans '(0 0 1) 1 0 T)

			       (setq no (vlax-get ob 'Normal))

			       1e-9

			)

		   )

		   (and	(= typ "AcDbPolyline")

			(/= 0 (vla-get-Elevation ob))

		   )

		   (and (= typ "AcDb2dPolyline") (/= 0 (caddar co)))

		 )

	    )

	  (progn

	    (setq ucs (vla-add

			(vla-get-UserCoordinateSystems AcDoc)

			(vlax-3d-point (setq org (getvar "UCSORG")))

			(vlax-3d-point (mapcar '+ org (getvar "UCSXDIR")))

			(vlax-3d-point (mapcar '+ org (getvar "UCSYDIR")))

			"addvtxUCS"

		      )

		  ocs (vla-add

			(vla-get-UserCoordinateSystems AcDoc)

			(vlax-3d-Point

			  (setq org (vlax-curve-getStartPoint ob))

			)

			(vlax-3d-Point

			  (mapcar '+ org (trans '(1 0 0) no 0))

			)

			(vlax-3d-Point

			  (mapcar '+ org (trans '(0 1 0) no 0))

			)

			"addvtxOCS"

		      )

	    )

	    (vla-put-activeUCS AcDoc ocs)

	  )

	)

	(if (setq

	      pt

	       (getpoint (trans (vlax-curve-getPointAtParam ob pa) 0 1)

			 "\nPick \U+0111i\U+1EC3m th\U+00EAm vertex : "

	       )

	    )

	  (progn

	    (and ep (setq pa (- (length co) 2)))

	    (if	(/= typ "AcDb3dPolyline")

	      (progn

		(setq p1 (trans (vlax-curve-getPointAtParam ob pa) 0 no)

		      pt (trans pt 1 no)

		      p2 (trans	(vlax-curve-getPointAtParam ob (1+ pa))

				0

				no

			 )

		)

		(cond

		  ((and ep (/= 0 (vla-getBulge ob pa)))

		   ((lambda (a)

		      (setq

			bu

			 (list (cons (1+ (fix pa)) (/ (sin a) (cos a))))

		      )

		    )

		     (/

		       (- (angle p2 pt)

			  (+ (angle p2 p1)

			     (* 2 (atan (vla-getBulge ob pa)))

			     pi

			  )

		       )

		       2.0

		     )

		   )

		  )

		  ((and sp (/= 0 (vla-getBulge ob pa)))

		   ((lambda (a)

		      (setq

			bu (list (cons 0 (/ (sin a) (cos a))))

		      )

		    )

		     (/

		       (- (+ (angle p1 p2)

			     (* -2 (atan (vla-getBulge ob pa)))

			     pi

			  )

			  (angle p1 pt)

		       )

		       2.0

		     )

		   )

		  )

		  (T

		   (setq

		     ce	((lambda (mid1 mid2)

			   (inters mid1

				   (polar mid1

					  (+ (angle p1 pt) (/ pi 2))

					  1.0

				   )

				   mid2

				   (polar mid2

					  (+ (angle pt p2) (/ pi 2))

					  1.0

				   )

				   nil

			   )

			 )

			  (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0))

				  p1

				  pt

			  )

			  (mapcar '(lambda (x1 x2) (/ (+ x1 x2) 2.0))

				  pt

				  p2

			  )

			)

		   )

		   (if (or (= 0 (vla-getBulge ob pa)) (null ce))

		     (setq a1 0.0

			   a2 0.0

		     )

		     (if (< pi

			    (ang<2pi (- (angle pt p2) (angle p1 pt)))

			    (* 2 pi)

			 )

		       (setq a1	(- (ang<2pi (- (angle ce p1) (angle ce pt)))

				)

			     a2	(- (ang<2pi (- (angle ce pt) (angle ce p2)))

				)

		       )

		       (setq a1	(ang<2pi (- (angle ce pt) (angle ce p1)))

			     a2	(ang<2pi (- (angle ce p2) (angle ce pt)))

		       )

		     )

		   )

		   (setq bu

			  (list	(cons pa (/ (sin (/ a1 4.0)) (cos (/ a1 4.0))))

				(cons (1+ (fix pa))

				      (/ (sin (/ a2 4.0)) (cos (/ a2 4.0)))

				)

			  )

		   )

		  )

		)

		(vla-getWidth ob pa 'sw 'ew)

		(cond

		  ((equal pk (vlax-curve-getStartPoint ob) ap)

		   (setq

		     pw	(+ sw

			   (/ (* (distance p1 pt) (- ew sw))

			      (+ (distance pt p1) (distance p1 p2))

			   )

			)

		   )

		  )

		  ((equal pk (vlax-curve-getEndPoint ob) ap)

		   (setq

		     pw	(+ sw

			   (/ (* (distance p1 p2) (- ew sw))

			      (+ (distance pt p2) (distance p1 p2))

			   )

			)

		   )

		  )

		  (T

		   (setq

		     pw	(+ sw

			   (/ (* (distance p1 pt) (- ew sw))

			      (+ (distance p1 pt) (distance pt p2))

			   )

			)

		   )

		  )

		)

		(setq wi (list (list pa sw pw) (list (1+ pa) pw ew))

		      nw (1+ pa)

		)

		(repeat	(- (fix (vlax-curve-getEndParam ob)) (1+ pa))

		  (vla-getWidth ob nw 'sw 'ew)

		  (setq wi (cons (list (setq nw (1+ nw)) sw ew) wi))

		)

	      )

	    )

	    (cond

	      ((= typ "AcDbPolyline")

	       (setq pt (list (car pt) (cadr pt)))

	      )

	      ((= typ "AcDb3dPolyline") (setq pt (trans pt 1 0)))

	    )

	    (or sp (setq pa (1+ pa)))

	    (cond

	      (sp (setq co (cons pt co)))

	      (ep (setq co (append co (list pt))))

	      (T

	       (setq co	(append	(sublist co 0 pa)

				(cons pt (sublist co pa nil))

			)

	       )

	      )

	    )

	    (or

	      (= typ "AcDb3dPolyline")

	      (while (<= (setq pa (1+ pa)) (vlax-curve-getEndParam ob))

		(setq bu (cons (cons pa (vla-getBulge ob (1- pa))) bu))

	      )

	    )

	    (vlax-put ob 'Coordinates (apply 'append co))

	    (or	(= typ "AcDb3dPolyline")

		(and

		  (mapcar '(lambda (x) (vla-setBulge ob (car x) (cdr x)))

			  bu

		  )

		  (mapcar '(lambda (x)

			     (vla-setWidth ob (car x) (cadr x) (caddr x))

			   )

			  wi

		  )

		)

	    )

	    (and ucs (vla-put-activeUCS AcDoc ucs))

	    (vla-EndUndoMark AcDoc)

	  )

	)

      )

      (progn	 

	(alert "Ch\U+1ECDn sai \U+0111\U+1ED1i t\U+01B0\U+1EE3ng!")

	(exit)

      ) 

    );end if check type

	);end T

	);end cond

	

  );end while

    (and ocs (vla-delete ocs) (setq ocs nil))

  (setq	*error*	m:err

	m:err nil

  )  

  (princ)

)



(defun DelVtx	(/ err os pt ent typ plst par blst n wlst)

  (vl-load-com)

  (setq	m:err	*error*

	*error*	err

	os	(getvar "OSMODE")

	  )

  (setvar "OSMODE" 1)		

  (while 

	(or (initget "u")

	(setq pt

		(getpoint

		  "\nCh\U+1ECDn vertex c\U+1EA7n x\U+00F3a :"

		)

	 ))

(cond  ((or(= pt "u")(= pt "U"))(vl-cmdf "undo" "back"))

	(T

   (if	(and

	  (setq	ent (ssget pt

			   '((-4 . "<OR")

			     (0 . "LWPOLYLINE")

			     (-4 . "<AND")

			     (0 . "POLYLINE")

			     (-4 . "<NOT")

			     (-4 . "&")

			     (70 . 118)

			     (-4 . "NOT>")

			     (-4 . "AND>")

			     (-4 . "OR>")

			    )

		    )

	  )

	  (setq ent (vlax-ename->vla-object (ssname ent 0)))

	  (setq typ (vla-get-ObjectName ent))

	)

      (if

	(and

	  (setq	plst (if (= typ "AcDbPolyline")

		       (split-list (vlax-get ent 'Coordinates) 2)

		       (split-list (vlax-get ent 'Coordinates) 3)

		     )

	  )

	  (< 2 (length plst))

	)

	 (progn

	   (vl-cmdf "undo" "mark")	   

	   (setq pt   (trans pt 1 0)

		 par  (cond

			((equal pt (vlax-curve-getStartPoint ent) 1e-9)

			 0

			)

			((equal pt (vlax-curve-getEndPoint ent) 1e-9)

			 (1- (length plst))

			)

			(T

			 (atoi (rtos (vlax-curve-getParamAtPoint ent pt) 2)

			 )

			)

		      )

		 blst nil

		 wlst nil

		 n    0

	   )

	   (if (/= typ "AcDb3dPolyline")

	     (progn

	       (repeat (length plst)

		 (if (/= n par)

		   (setq

		     blst

		      (cons (cons (length blst) (vla-getBulge ent n))

			    blst

		      )

		   )

		 )

		 (setq n (1+ n))

	       )

	       (if (/= 0 par)

		 (progn

		   (vla-getWidth ent (1- par) 'swid1 'ewid1)

		   (vla-getWidth ent par 'swid2 'ewid2)

		   (setq wlst (cons (list (1- par) swid1 ewid2) wlst))

		 )

	       )

	       (repeat

		 (- (setq n (1- (fix (vlax-curve-getEndParam ent))))

		    par

		 )

		  (vla-getWidth ent n 'swid 'ewid)

		  (setq

		    wlst (cons (list (setq n (1- n)) swid ewid) wlst)

		  )

	       )

	     )

	   )

	   (vlax-put ent

		     'Coordinates

		     (apply 'append (vl-remove (nth par plst) plst))

	   )

	   (or (= typ "AcDb3dPolyline")

	       (and

		 (mapcar '(lambda (x) (vla-setBulge ent (car x) (cdr x)))

			 blst

		 )

		 (mapcar '(lambda (x)

			    (vla-setWidth ent (car x) (cadr x) (caddr x))

			  )

			 wlst

		 )

	       )

	   )

	   (vla-EndUndoMark

	     (vla-get-ActiveDocument (vlax-get-acad-object))

	   )

	 )

	 (progn

	   (alert "\nKh\U+00F4ng th\U+1EC3 x\U+00F3a \U+0111\U+01B0\U+1EE3c, Pline n\U+00E0y ch\U+1EC9 c\U+00F3 1 ph\U+00E2n \U+0111o\U+1EA1n!")

	   (exit)

	 )

      )

      (progn

	(alert "Ch\U+1ECDn sai \U+0111\U+1ED1i t\U+01B0\U+1EE3ng!")

	(exit)

      )

    )

	);endT

	);end cond

  )

  (setvar "OSMODE" os)

  (setq	*error*	m:err

	m:err nil

  )

  (princ)

)



;;; SUBLIST Return a sub-list

;;;

;;; Arguments

;;; lst : a list

;;; start : start index for the sub-list (first item = 0)

;;; leng : sub-list length (or nil)

;;;

;;; Examples :

;;; (sublist '(1 2 3 4 5 6) 2 2) -> (3 4)

;;; (sublist '(1 2 3 4 5 6) 2 nil) -> (3 4 5 6)



(defun sublist (lst start leng / n r)

  (if (or (not leng) (< (- (length lst) start) leng))

    (setq leng (- (length lst) start))

  )

  (setq n (+ start leng))

  (repeat leng

    (setq r (cons (nth (setq n (1- n)) lst) r))

  )

)



;; SPLIT-LIST Split a list into sub-lists

;; Arguments

;; - lst : the list to be splited

;; - num : an integer, the number of items of sub-lists

;; Examples :

;; (split-list '(1 2 3 4 5 6 7 8) 2) -> ((1 2) (3 4) (5 6) (7 8))

;; (split-list '(1 2 3 4 5 6 7 8) 3) -> ((1 2 3) (4 5 6) (7 8))



(defun split-list (lst n)

  (if lst

    (cons (sublist lst 0 n)

	  (split-list (sublist lst n nil) n)

    )

  )

)



;;; ANG<2PI

;; Transform any angle (in radians) into its equivalent between 0 and 2*pi



(defun ang<2pi (ang)

  (if (and (<= 0 ang) (< ang (* 2 pi)))

    ang

    (ang<2pi (rem (+ ang (* 2 pi)) (* 2 pi)))

  )

)





(defun err (msg)

    (if	(or

	  (= msg "Function cancelled")

	  (= msg "quit / exit abort")

	)

      (princ)

      (princ (strcat "\nError: " msg))

    )

    (vla-EndUndoMark

      (vla-get-ActiveDocument (vlax-get-acad-object))

    )

    (setvar "OSMODE" os)

    (setq *error* m:err

	  m:err	nil

    )

  )

Mong mọi người giúp sao em dùng lisp này cho cad 2005 đc ko ạ, em dùng trên cad 2007 thì ngon lành nhưng qua cad 2005 thì ko được ạ
  • 0

#24 phuhvp

phuhvp

    biết vẽ line

  • Members
  • PipPip
  • 24 Bài viết
Điểm đánh giá: -2 (bình thường)

Đã gửi 06 July 2016 - 04:13 PM

Các bác có thể sửa dùm em 1 chút để lisp có thể chạy được trên file này cad 2005 được không ạ.. em muốn chỉnh sửa đường trắc ngang tự nhiên mà không dùng được trên nova cad 2005 , em test trên 2007 thì ok ạ

Mong mọi người bỏ ít công sức giúp đỡ


  • 0