Đến nội dung


Hình ảnh
- - - - -

[ Yêu cầu ] Sửa lisp tự động extend và trim các đường Pline


  • Please log in to reply
6 replies to this topic

#1 hoacomay70

hoacomay70

    biết vẽ circle

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

Đã gửi 05 December 2014 - 09:53 AM

Em tìm được trên mạng lisp sau tự động extend và trim các đường Pline

auto-trim-extend.gif?w=640

;;; Touch.LSP *
;;; Small routine to align endpoints of lines to an edge. *
;;; The edge have to be a line. *
;;; The routine works by calculating the point of inter- *
;;; section and change the nearest endpoint to that point *
;;; 2001 Stig Madsen, no rights reserved *
;;; modified by qjchen, the edge line can be line or polyline *
;
;GREAT for PROJECTING LINES FOR ELEVATIONS !!!!!!!!!!!
;
(defun C:Ttt (/ cmd ent entl spt ept sset a lent lentl lspt lept lint)
(vl-load-com)
(setq cmd (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(command "UNDO" "Begin")
(while (not ent)
(setq ent (car (entsel "Select edge line: ")))
(if ent
(progn
    (setq entl (entget ent))
)
)
)
(if ent
(progn
(redraw ent 3)
(prompt "\nSelect lines to touch edge: ")
(setq sset (ssget '((0 . "LINE")))
     a 0
)
(if sset
    (repeat (sslength sset)
     (setq lentl (entget (setq lent (ssname sset a)))
        lspt (cdr (assoc 10 lentl))
        lept (cdr (assoc 11 lentl))
     )
     (setq entttt (ssname sset a))
     (setq lint (nth 0 (x_intlst ent entttt acExtendOtherEntity)))
     (if lint
     (progn

     (if (< (distance lint lspt) (distance lint lept))
        (entmod (subst
             (cons 10 lint)
             (assoc 10 lentl)
             lentl
            )
        )
        (entmod (subst
             (cons 11 lint)
             (assoc 11 lentl)
             lentl
            )
        )
     )
     )
     )
     (setq a (1+ a))
    )
    (princ "\nNo objects found")
)
(redraw ent 4)
)
(princ "\nNo edge selected")
)
(setvar "CMDECHO" cmd)
(command "UNDO" "End")
(princ)
)

;;; by kuangdao at xdcad
(defun x_intlst (obj1 obj2 param / intlst1 intlst2 ptlst)

(if (= 'ENAME (type obj1))
(setq obj1 (vlax-ename->vla-object obj1))
)
(if (= 'ENAME (type obj2))
(setq obj2 (vlax-ename->vla-object obj2))
)
(setq intlst1 (vlax-variant-value (vla-intersectwith obj1 obj2 param)))
(if (< 0 (vlax-safearray-get-u-bound intlst1 1))
(progn
(setq intlst2 (vlax-safearray->list intlst1))
(while (> (length intlst2) 0)
    (setq ptlst (cons (list (car intlst2) (cadr intlst2) (caddr intlst2))
             ptlst
         )
     intlst2 (cdddr intlst2)
    )
)
)
)
ptlst
)

 

Tuy nhiên như trên lisp chỉ chọn được 1 đường Pline màu xanh, sau đó còn quét chọn tất cả các đường khác lại là đường Line. Em muốn nhờ sửa để lisp có thể chọn được nhiều đường Pline, sau đó quét chọn những đường còn lại cũng là đường Pline để tự động  extend và trim như hình dưới đây. 

125447_maumau_1.png

Lisp sẽ yêu cầu chọn các đường Pline cho trước màu xanh, sau đó quét hết các các đường trên bản vẽ, các đường Pline màu đỏ sẽ tự động extend và trim với đường Pline màu xanh gần nó nhất. 

Em xin cảm ơn.

 

 


  • 0

#2 hoacomay70

hoacomay70

    biết vẽ circle

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

Đã gửi 12 December 2014 - 02:09 PM

Hic có cao thủ nào giúp em với.


  • 0

#3 bach1212

bach1212

    biết lệnh trim

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

Đã gửi 07 July 2015 - 04:29 PM

Yêu cầu của bạn sẽ rất hữu ích cho công việc. Mong các bác siêu lisp giúp đỡ!  :D

Ít nhất thì sửa được cho lisp chọn cả đối tượng là Pline.


  • 0

Một môn tập luyện mang lại vô vàn lợi ích sức khỏe cho mọi người, nhiều bệnh tật nan y đều được chữa khỏi, hoàn toàn miễn phí. Hiệu quả chữa khỏi bệnh tật của nó lên đến hơn 90%.
Tài liệu tại đây: http://phapluan.org/

Rất vui được làm quen với mọi người trên facebook:
https://www.facebook...67946371&type=1

 

 


#4 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 993 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 08 July 2015 - 09:18 AM

Vấn đề này không khó. Tuy nhiên các Pline phải dời dạc và cách nhau một khoảng cách nhất định.

Nếu như sửa thì sẽ chỉ cần thao tác quét chọn Pline. Sẽ dựa vào kích thước của Pline mà có vùng chọn nhất định để bao các Line xung quanh. Như vậy vấn đề sẽ được giải quyết.


  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#5 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 993 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 08 July 2015 - 09:47 AM

Bạn thử xem nhé!

(defun C:TTT (   /  LTSPLINE X)
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setq LtsPline (CV:ss-to-list (ssget (list (cons 0 "*LWPOLYLINE,POLYLINE"))) nil))
  (command "Zoom" "e")
  (mapcar '(lambda(x)(Ttt1 x)) LtsPline)
(setvar "OSMODE" Olmode)
(princ)
)

(defun Ttt1 (ent  / A  CMD ENTTTT HV KC12 LENT LENTL LEPT LINT LSPT P1 P2 PNT_D PNT_T SSET TV)
  (vl-load-com)
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setvar "OSMODE" 0)
  (command "UNDO" "Begin")
;;;  (while (not ent)
;;;    (setq ent (car (entsel "Select edge line: ")))
;;;    (if	ent
;;;      (progn
;;;	(setq entl (entget ent))
;;;      )
;;;    )
;;;  )
  (if ent
    (progn
      (redraw ent 3)
      (setq a 0)
      (setq HV (LM:ssboundingbox (CV:List-to-ss (list ent))))
      (setq P1 (car HV))
      (setq P2 (cadr HV))
      (setq KC12 (distance P1 P2))
      (setq TV (list (/ (+ (car P1) (car P2)) 2) (/ (+ (cadr P1) (cadr P2)) 2)))
      (setq Pnt_T (list (- (car TV) (/ KC12 2)) (+ (cadr TV) (/ KC12 2))))
      (setq Pnt_D (list (+ (car TV) (/ KC12 2)) (- (cadr TV) (/ KC12 2))))
      (setq sset (ssget "W" Pnt_T Pnt_D (list (cons 0 "LINE"))))
      (if sset
	(repeat	(sslength sset)
	  (setq	lentl (entget (setq lent (ssname sset a)))
		lspt  (cdr (assoc 10 lentl))
		lept  (cdr (assoc 11 lentl))
	  )
	  (setq entttt (ssname sset a))
	  (setq lint (nth 0 (x_intlst ent entttt acExtendOtherEntity)))
	  (if lint
	    (progn

	      (if (< (distance lint lspt) (distance lint lept))
		(entmod	(subst
			  (cons 10 lint)
			  (assoc 10 lentl)
			  lentl
			)
		)
		(entmod	(subst
			  (cons 11 lint)
			  (assoc 11 lentl)
			  lentl
			)
		)
	      )
	    )
	  )
	  (setq a (1+ a))
	)
	
      )
      (redraw ent 4)
    )
  )
  (setvar "CMDECHO" cmd)
  (command "UNDO" "End")
  (princ)
)

;;; by kuangdao at xdcad
(defun x_intlst	(obj1 obj2 param / intlst1 intlst2 ptlst)

  (if (= 'ENAME (type obj1))
    (setq obj1 (vlax-ename->vla-object obj1))
  )
  (if (= 'ENAME (type obj2))
    (setq obj2 (vlax-ename->vla-object obj2))
  )
  (setq
    intlst1 (vlax-variant-value (vla-intersectwith obj1 obj2 param))
  )
  (if (< 0 (vlax-safearray-get-u-bound intlst1 1))
    (progn
      (setq intlst2 (vlax-safearray->list intlst1))
      (while (> (length intlst2) 0)
	(setq ptlst   (cons (list (car intlst2) (cadr intlst2) (caddr intlst2))
			    ptlst
		      )
	      intlst2 (cdddr intlst2)
	)
      )
    )
  )
  ptlst
)

(defun LM:ssboundingbox ( s / a b i m n o )
    (repeat (setq i (sslength s))
        (if
            (and
                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
                (vlax-method-applicable-p o 'getboundingbox)
                (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
            )
            (setq m (cons (vlax-safearray->list a) m)
                  n (cons (vlax-safearray->list b) n)
            )
        )
    )
    (if (and m n)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
    )
)

(defun CV:List-to-ss (lst / ss)
(setq ss (ssadd))
(foreach item lst
  (or (= (type item ) 'Ename)
   (setq item (vlax-vla-object->ename  item)))
  (setq ss (ssadd item ss))
)
ss
)

(defun CV:ss-to-list (ss vla / n e l)
  (setq n (sslength ss))
  (while (setq e (ssname ss (setq n (1- n))))
	(setq l (cons (if vla (vlax-ename->vla-object e) e) l))
  ) 
)

  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn







#6 hoacomay70

hoacomay70

    biết vẽ circle

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

Đã gửi 14 July 2015 - 10:52 AM

 

Bạn thử xem nhé!

(defun C:TTT (   /  LTSPLINE X)
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setq LtsPline (CV:ss-to-list (ssget (list (cons 0 "*LWPOLYLINE,POLYLINE"))) nil))
  (command "Zoom" "e")
  (mapcar '(lambda(x)(Ttt1 x)) LtsPline)
(setvar "OSMODE" Olmode)
(princ)
)

(defun Ttt1 (ent  / A  CMD ENTTTT HV KC12 LENT LENTL LEPT LINT LSPT P1 P2 PNT_D PNT_T SSET TV)
  (vl-load-com)
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setvar "OSMODE" 0)
  (command "UNDO" "Begin")
;;;  (while (not ent)
;;;    (setq ent (car (entsel "Select edge line: ")))
;;;    (if	ent
;;;      (progn
;;;	(setq entl (entget ent))
;;;      )
;;;    )
;;;  )
  (if ent
    (progn
      (redraw ent 3)
      (setq a 0)
      (setq HV (LM:ssboundingbox (CV:List-to-ss (list ent))))
      (setq P1 (car HV))
      (setq P2 (cadr HV))
      (setq KC12 (distance P1 P2))
      (setq TV (list (/ (+ (car P1) (car P2)) 2) (/ (+ (cadr P1) (cadr P2)) 2)))
      (setq Pnt_T (list (- (car TV) (/ KC12 2)) (+ (cadr TV) (/ KC12 2))))
      (setq Pnt_D (list (+ (car TV) (/ KC12 2)) (- (cadr TV) (/ KC12 2))))
      (setq sset (ssget "W" Pnt_T Pnt_D (list (cons 0 "LINE"))))
      (if sset
	(repeat	(sslength sset)
	  (setq	lentl (entget (setq lent (ssname sset a)))
		lspt  (cdr (assoc 10 lentl))
		lept  (cdr (assoc 11 lentl))
	  )
	  (setq entttt (ssname sset a))
	  (setq lint (nth 0 (x_intlst ent entttt acExtendOtherEntity)))
	  (if lint
	    (progn

	      (if (< (distance lint lspt) (distance lint lept))
		(entmod	(subst
			  (cons 10 lint)
			  (assoc 10 lentl)
			  lentl
			)
		)
		(entmod	(subst
			  (cons 11 lint)
			  (assoc 11 lentl)
			  lentl
			)
		)
	      )
	    )
	  )
	  (setq a (1+ a))
	)
	
      )
      (redraw ent 4)
    )
  )
  (setvar "CMDECHO" cmd)
  (command "UNDO" "End")
  (princ)
)

;;; by kuangdao at xdcad
(defun x_intlst	(obj1 obj2 param / intlst1 intlst2 ptlst)

  (if (= 'ENAME (type obj1))
    (setq obj1 (vlax-ename->vla-object obj1))
  )
  (if (= 'ENAME (type obj2))
    (setq obj2 (vlax-ename->vla-object obj2))
  )
  (setq
    intlst1 (vlax-variant-value (vla-intersectwith obj1 obj2 param))
  )
  (if (< 0 (vlax-safearray-get-u-bound intlst1 1))
    (progn
      (setq intlst2 (vlax-safearray->list intlst1))
      (while (> (length intlst2) 0)
	(setq ptlst   (cons (list (car intlst2) (cadr intlst2) (caddr intlst2))
			    ptlst
		      )
	      intlst2 (cdddr intlst2)
	)
      )
    )
  )
  ptlst
)

(defun LM:ssboundingbox ( s / a b i m n o )
    (repeat (setq i (sslength s))
        (if
            (and
                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
                (vlax-method-applicable-p o 'getboundingbox)
                (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
            )
            (setq m (cons (vlax-safearray->list a) m)
                  n (cons (vlax-safearray->list b) n)
            )
        )
    )
    (if (and m n)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
    )
)

(defun CV:List-to-ss (lst / ss)
(setq ss (ssadd))
(foreach item lst
  (or (= (type item ) 'Ename)
   (setq item (vlax-vla-object->ename  item)))
  (setq ss (ssadd item ss))
)
ss
)

(defun CV:ss-to-list (ss vla / n e l)
  (setq n (sslength ss))
  (while (setq e (ssname ss (setq n (1- n))))
	(setq l (cons (if vla (vlax-ename->vla-object e) e) l))
  ) 
)

Bac oi minh chi duoc quet chon doi tuong mot lan thoi a? Cach dung the nao vay a. Em quet chon thi khong thay gi ca. Bac xem giup em duoc khong. Cam on bac rat nhieu.


  • 0

#7 thanhduan2407

thanhduan2407

    biết lệnh adcenter

  • Advance Member
  • PipPipPipPipPipPipPip
  • 993 Bài viết
Điểm đánh giá: 223 (khá)

Đã gửi 14 July 2015 - 10:46 PM

 

 

Bạn thử xem nhé!

(defun C:TTT (   /  LTSPLINE X)
  (defun *error* (msg)
    (if	Olmode
      (setvar 'osmode Olmode)
    )
    (if	(not (member msg '("*BREAK,*CANCEL*,*EXIT*")))
      (princ (strcat "\nError: " msg))
    )
    (princ)
  )
  (setq Olmode (getvar "OSMODE"))
  (setq LtsPline (CV:ss-to-list (ssget (list (cons 0 "*LWPOLYLINE,POLYLINE"))) nil))
  (command "Zoom" "e")
  (mapcar '(lambda(x)(Ttt1 x)) LtsPline)
(setvar "OSMODE" Olmode)
(princ)
)

(defun Ttt1 (ent  / A  CMD ENTTTT HV KC12 LENT LENTL LEPT LINT LSPT P1 P2 PNT_D PNT_T SSET TV)
  (vl-load-com)
  (setq cmd (getvar "CMDECHO"))
  (setvar "CMDECHO" 0)
  (setvar "OSMODE" 0)
  (command "UNDO" "Begin")
;;;  (while (not ent)
;;;    (setq ent (car (entsel "Select edge line: ")))
;;;    (if	ent
;;;      (progn
;;;	(setq entl (entget ent))
;;;      )
;;;    )
;;;  )
  (if ent
    (progn
      (redraw ent 3)
      (setq a 0)
      (setq HV (LM:ssboundingbox (CV:List-to-ss (list ent))))
      (setq P1 (car HV))
      (setq P2 (cadr HV))
      (setq KC12 (distance P1 P2))
      (setq TV (list (/ (+ (car P1) (car P2)) 2) (/ (+ (cadr P1) (cadr P2)) 2)))
      (setq Pnt_T (list (- (car TV) (/ KC12 2)) (+ (cadr TV) (/ KC12 2))))
      (setq Pnt_D (list (+ (car TV) (/ KC12 2)) (- (cadr TV) (/ KC12 2))))
      (setq sset (ssget "W" Pnt_T Pnt_D (list (cons 0 "LINE"))))
      (if sset
	(repeat	(sslength sset)
	  (setq	lentl (entget (setq lent (ssname sset a)))
		lspt  (cdr (assoc 10 lentl))
		lept  (cdr (assoc 11 lentl))
	  )
	  (setq entttt (ssname sset a))
	  (setq lint (nth 0 (x_intlst ent entttt acExtendOtherEntity)))
	  (if lint
	    (progn

	      (if (< (distance lint lspt) (distance lint lept))
		(entmod	(subst
			  (cons 10 lint)
			  (assoc 10 lentl)
			  lentl
			)
		)
		(entmod	(subst
			  (cons 11 lint)
			  (assoc 11 lentl)
			  lentl
			)
		)
	      )
	    )
	  )
	  (setq a (1+ a))
	)
	
      )
      (redraw ent 4)
    )
  )
  (setvar "CMDECHO" cmd)
  (command "UNDO" "End")
  (princ)
)

;;; by kuangdao at xdcad
(defun x_intlst	(obj1 obj2 param / intlst1 intlst2 ptlst)

  (if (= 'ENAME (type obj1))
    (setq obj1 (vlax-ename->vla-object obj1))
  )
  (if (= 'ENAME (type obj2))
    (setq obj2 (vlax-ename->vla-object obj2))
  )
  (setq
    intlst1 (vlax-variant-value (vla-intersectwith obj1 obj2 param))
  )
  (if (< 0 (vlax-safearray-get-u-bound intlst1 1))
    (progn
      (setq intlst2 (vlax-safearray->list intlst1))
      (while (> (length intlst2) 0)
	(setq ptlst   (cons (list (car intlst2) (cadr intlst2) (caddr intlst2))
			    ptlst
		      )
	      intlst2 (cdddr intlst2)
	)
      )
    )
  )
  ptlst
)

(defun LM:ssboundingbox ( s / a b i m n o )
    (repeat (setq i (sslength s))
        (if
            (and
                (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
                (vlax-method-applicable-p o 'getboundingbox)
                (not (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))))
            )
            (setq m (cons (vlax-safearray->list a) m)
                  n (cons (vlax-safearray->list b) n)
            )
        )
    )
    (if (and m n)
        (mapcar '(lambda ( a b ) (apply 'mapcar (cons a b))) '(min max) (list m n))
    )
)

(defun CV:List-to-ss (lst / ss)
(setq ss (ssadd))
(foreach item lst
  (or (= (type item ) 'Ename)
   (setq item (vlax-vla-object->ename  item)))
  (setq ss (ssadd item ss))
)
ss
)

(defun CV:ss-to-list (ss vla / n e l)
  (setq n (sslength ss))
  (while (setq e (ssname ss (setq n (1- n))))
	(setq l (cons (if vla (vlax-ename->vla-object e) e) l))
  ) 
)

Bac oi minh chi duoc quet chon doi tuong mot lan thoi a? Cach dung the nao vay a. Em quet chon thi khong thay gi ca. Bac xem giup em duoc khong. Cam on bac rat nhieu.

 

Chỉ cần quét Pline thôi bạn à


  • 0



Tôi là con kiến bò trên sa mạc kiến thức bao la. Biển học thật rộng lớn