Chuyển đến nội dung
Diễn đàn CADViet
Mr Việt

[Yêu cầu] Lisp Move đối tượng hàng loạt được chọn trước

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

Nhờ các bác viết dùm em Lisp Move các đối tượng được chọn trước ở chế độ truy bắt điểm Insertion, Move về bắt vuông góc với đoạn thẳng được chỉ định cần Move các đối tượng đến.

Thank all !!!

 

Mình gửi kèm File trước và sau khi Move, trong đó có nội dung yêu cầu

 

http://www.cadviet.com/upfiles/3/107685_viet_lisp.dwg

 

 

https://docs.google.com/file/d/0B6VDxh0jfse5S1RKWXp4R2pfaFU/edit?usp=sharing

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

 

Nhờ các bác viết dùm em Lisp Move các đối tượng được chọn trước ở chế độ truy bắt điểm Insertion, Move về bắt vuông góc với đoạn thẳng được chỉ định cần Move các đối tượng đến.

Thank all !!!

 

Mình gửi kèm File trước và sau khi Move, trong đó có nội dung yêu cầu

 

http://www.cadviet.com/upfiles/3/107685_viet_lisp.dwg

 

 

https://docs.google.com/file/d/0B6VDxh0jfse5S1RKWXp4R2pfaFU/edit?usp=sharing

Tôi đã xem bản vẽ của bạn nhưng không hiểu dòng màu đỏ ở trên?

Hình như bộ 3 gồm 1 point + 2 text là đi liền nhau, nếu move là move nguyên cả bộ 3 ấy?

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

Move cả 3 cũng được hoặc Text hay point, nói chung do mình chọn cái nào thì Move cái đó.

 

Bắt tâm điểm của đối tượng cần Move

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

Lisp move từng nhóm đối tượng đến 1 Line cho trước.

Có 4 cách chọn kiểu đối tượng để Move: Point (nhập "P"), Text phía trên (nhập "TT"), Text phía dưới (nhập "TD") và cả 3 đối tượng (nhập "3").

Lệnh dùng: HA


;Doan Van Ha - CADViet.com - Ngay 16/6/2013
;Chuc nang: Move tung nhom doi tuong den 1 Lien.
(defun C:HA( / kieu typ lay ent ss p1 p2 pt z osm cmd)
 (command "undo" "be") (setq osm (getvar "osmode") cmd (getvar "cmdecho"))
 (initget "P TT TD 3")
 (setq kieu (getkword "\nKieu doi tuong can Move [point la P/text tren la TT/ text duoi la TD/tat ca la 3]: "))
 (cond
  ((= kieu "P") (setq typ "Point" lay "diem"))
  ((= kieu "TT") (setq typ "Text" lay "Tendiem"))
  ((= kieu "TD") (setq typ "Text" lay "Docao"))
  ((= kieu "3") (setq typ "Point,Text" lay "diem,Tendiem,Docao")))
 (if
  (and
   (setq ent (car (entsel "\nChon Line: ")))
   (princ "\nChon cac doi tuong can Move...")
   (setq ss (ssget (list (cons 0 typ) (cons 8 lay)))))
  (progn 
   (setvar "osmode" 0) (setvar "cmdecho" 0)
   (setq p1 (cdr (assoc 10 (entget ent))))
   (setq p2 (cdr (assoc 11 (entget ent))))
   (setq z -1)
   (repeat (sslength ss)
    (setq pt (cdr (assoc 10 (entget (ssname ss (setq z (1+ z)))))))
    (command "move" ss "" pt (FindPerpPoint p1 p2 pt)))))
 (setvar "osmode" osm) (setvar "cmdecho" cmd) (command "undo" "e") (princ))
(defun FindPerpPoint (p1 p2 q / x1 x2 x3 y1 y2 y3 z1 z2 z3 T4)
 (setq x1 (car p1) x2 (car p2) x3 (car q)
       y1 (cadr p1) y2 (cadr p2) y3 (cadr q)
       z1 (caddr p1) z2 (caddr p2) z3 (caddr q)
       T4 (/ (+ (* (- x2 x1) (- x3 x1)) (* (- y2 y1) (- y3 y1)) (* (- z2 z1) (- z3 z1)))
             (+ (* (- x2 x1) (- x2 x1)) (* (- y2 y1) (- y2 y1)) (* (- z2 z1) (- z2 z1)))))
 (list (+ x1 (* T4 (- x2 x1))) (+ y1 (* T4 (- y2 y1))) (+ z1 (* T4 (- z2 z1)))))

  • 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

Thank bác Doan Van Ha đã viết giúp, nhưng chưa được như ý muốn của em, nó vẫn chưa Move về điểm vuông góc với đoạn thẳng như file em gửi kèm.

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

Nếu chọn từng đối tượng thì ok, nhưng nếu chọn toàn bộ đối tượng trong mặt cắt thì Move không vuông góc nữa.

Cụ thể là Move 1 bộ gồm 1 point + 2 Text thì ok, Move nhiều Point hoặc nhiều Text thì chỉ có 1 đối tượng vuông góc, các đối tượng khác không về điểm vuông góc với đoạn thẳng 

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

Srr, tôi viết gấp quá nên bị nhầm tí. Sửa lại đây!


;Doan Van Ha - CADViet.com - Ngay 16/6/2013
;Chuc nang: Move tung nhom doi tuong den 1 Lien.
(defun C:HA( / kieu typ lay ent ss p1 p2 pt z osm cmd)
 (command "undo" "be") (setq osm (getvar "osmode") cmd (getvar "cmdecho"))
 (initget "P TT TD 3")
 (setq kieu (getkword "\nKieu doi tuong can Move [point la P/text tren la TT/ text duoi la TD/tat ca la 3]: "))
 (cond
  ((= kieu "P") (setq typ "Point" lay "diem"))
  ((= kieu "TT") (setq typ "Text" lay "Tendiem"))
  ((= kieu "TD") (setq typ "Text" lay "Docao"))
  ((= kieu "3") (setq typ "Point,Text" lay "diem,Tendiem,Docao")))
 (if
  (and
   (setq ent (car (entsel "\nChon Line: ")))
   (princ "\nChon cac doi tuong can Move...")
   (setq ss (ssget (list (cons 0 typ) (cons 8 lay)))))
  (progn 
   (setvar "osmode" 0) (setvar "cmdecho" 0)
   (setq p1 (cdr (assoc 10 (entget ent))))
   (setq p2 (cdr (assoc 11 (entget ent))))
   (setq z -1)
   (repeat (sslength ss)
    (setq pt (cdr (assoc 10 (entget (ssname ss (setq z (1+ z)))))))
    (command "move" (ssname ss z) "" pt (FindPerpPoint p1 p2 pt)))))
 (setvar "osmode" osm) (setvar "cmdecho" cmd) (command "undo" "e") (princ))
(defun FindPerpPoint (p1 p2 q / x1 x2 x3 y1 y2 y3 z1 z2 z3 T4)
 (setq x1 (car p1) x2 (car p2) x3 (car q)
       y1 (cadr p1) y2 (cadr p2) y3 (cadr q)
       z1 (caddr p1) z2 (caddr p2) z3 (caddr q)
       T4 (/ (+ (* (- x2 x1) (- x3 x1)) (* (- y2 y1) (- y3 y1)) (* (- z2 z1) (- z3 z1)))
             (+ (* (- x2 x1) (- x2 x1)) (* (- y2 y1) (- y2 y1)) (* (- z2 z1) (- z2 z1)))))
 (list (+ x1 (* T4 (- x2 x1))) (+ y1 (* T4 (- y2 y1))) (+ z1 (* T4 (- z2 z1)))))

  • Like 2
  • Vote tăng 2

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
Vào lúc 16/6/2013 tại 15:20, Doan Van Ha đã nói:

Srr, tôi viết gấp quá nên bị nhầm tí. Sửa lại đây!

 



 
;Doan Van Ha - CADViet.com - Ngay 16/6/2013
;Chuc nang: Move tung nhom doi tuong den 1 Lien.
(defun C:HA( / kieu typ lay ent ss p1 p2 pt z osm cmd)
 (command "undo" "be") (setq osm (getvar "osmode") cmd (getvar "cmdecho"))
 (initget "P TT TD 3")
 (setq kieu (getkword "\nKieu doi tuong can Move [point la P/text tren la TT/ text duoi la TD/tat ca la 3]: "))
 (cond
  ((= kieu "P") (setq typ "Point" lay "diem"))
  ((= kieu "TT") (setq typ "Text" lay "Tendiem"))
  ((= kieu "TD") (setq typ "Text" lay "Docao"))
  ((= kieu "3") (setq typ "Point,Text" lay "diem,Tendiem,Docao")))
 (if
  (and
   (setq ent (car (entsel "\nChon Line: ")))
   (princ "\nChon cac doi tuong can Move...")
   (setq ss (ssget (list (cons 0 typ) (cons 8 lay)))))
  (progn 
   (setvar "osmode" 0) (setvar "cmdecho" 0)
   (setq p1 (cdr (assoc 10 (entget ent))))
   (setq p2 (cdr (assoc 11 (entget ent))))
   (setq z -1)
   (repeat (sslength ss)
    (setq pt (cdr (assoc 10 (entget (ssname ss (setq z (1+ z)))))))
    (command "move" (ssname ss z) "" pt (FindPerpPoint p1 p2 pt)))))
 (setvar "osmode" osm) (setvar "cmdecho" cmd) (command "undo" "e") (princ))
(defun FindPerpPoint (p1 p2 q / x1 x2 x3 y1 y2 y3 z1 z2 z3 T4)
 (setq x1 (car p1) x2 (car p2) x3 (car q)
       y1 (cadr p1) y2 (cadr p2) y3 (cadr q)
       z1 (caddr p1) z2 (caddr p2) z3 (caddr q)
       T4 (/ (+ (* (- x2 x1) (- x3 x1)) (* (- y2 y1) (- y3 y1)) (* (- z2 z1) (- z3 z1)))
             (+ (* (- x2 x1) (- x2 x1)) (* (- y2 y1) (- y2 y1)) (* (- z2 z1) (- z2 z1)))))
 (list (+ x1 (* T4 (- x2 x1))) (+ y1 (* T4 (- y2 y1))) (+ z1 (* T4 (- z2 z1)))))

 

Bác Hà có thể sửa lisp này có thể Move đối tượng là block được không ạ, cảm ơn bác nhiều

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
Vào lúc 16/6/2013 tại 15:20, Doan Van Ha đã nói:

Srr, tôi viết gấp quá nên bị nhầm tí. Sửa lại đây!

 



 
;Doan Van Ha - CADViet.com - Ngay 16/6/2013
;Chuc nang: Move tung nhom doi tuong den 1 Lien.
(defun C:HA( / kieu typ lay ent ss p1 p2 pt z osm cmd)
 (command "undo" "be") (setq osm (getvar "osmode") cmd (getvar "cmdecho"))
 (initget "P TT TD 3")
 (setq kieu (getkword "\nKieu doi tuong can Move [point la P/text tren la TT/ text duoi la TD/tat ca la 3]: "))
 (cond
  ((= kieu "P") (setq typ "Point" lay "diem"))
  ((= kieu "TT") (setq typ "Text" lay "Tendiem"))
  ((= kieu "TD") (setq typ "Text" lay "Docao"))
  ((= kieu "3") (setq typ "Point,Text" lay "diem,Tendiem,Docao")))
 (if
  (and
   (setq ent (car (entsel "\nChon Line: ")))
   (princ "\nChon cac doi tuong can Move...")
   (setq ss (ssget (list (cons 0 typ) (cons 8 lay)))))
  (progn 
   (setvar "osmode" 0) (setvar "cmdecho" 0)
   (setq p1 (cdr (assoc 10 (entget ent))))
   (setq p2 (cdr (assoc 11 (entget ent))))
   (setq z -1)
   (repeat (sslength ss)
    (setq pt (cdr (assoc 10 (entget (ssname ss (setq z (1+ z)))))))
    (command "move" (ssname ss z) "" pt (FindPerpPoint p1 p2 pt)))))
 (setvar "osmode" osm) (setvar "cmdecho" cmd) (command "undo" "e") (princ))
(defun FindPerpPoint (p1 p2 q / x1 x2 x3 y1 y2 y3 z1 z2 z3 T4)
 (setq x1 (car p1) x2 (car p2) x3 (car q)
       y1 (cadr p1) y2 (cadr p2) y3 (cadr q)
       z1 (caddr p1) z2 (caddr p2) z3 (caddr q)
       T4 (/ (+ (* (- x2 x1) (- x3 x1)) (* (- y2 y1) (- y3 y1)) (* (- z2 z1) (- z3 z1)))
             (+ (* (- x2 x1) (- x2 x1)) (* (- y2 y1) (- y2 y1)) (* (- z2 z1) (- z2 z1)))))
 (list (+ x1 (* T4 (- x2 x1))) (+ y1 (* T4 (- y2 y1))) (+ z1 (* T4 (- z2 z1)))))

 

 Nhờ Các Bác sửa giúp em code trên move hàng loạt đối tượng lên trên đường polyline .

Move.dwg

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
4 giờ trước, pdhuyxn2 đã nói:

 Nhờ Các Bác sửa giúp em code trên move hàng loạt đối tượng lên trên đường polyline .

Move.dwg

Gửi bạn nhé

lệnh MDT

(defun CV:ss-to-list (ss vla / n e l)
(if ss
(progn
(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))
)
)
)
) 
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)
(defun c:MDT (/ lstdt pl lstline lsttextvitri lsttextcoc point pointpl gocvuong pointden)
(setq lstdt (CV:ss-to-list (ssget '((0 . "TEXT,LINE"))) nil))
(setq pl (car (LM:SelectIf "\nChon duong Polyline:" (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))) 
															entsel nil)))
(setq lstline (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "LINE")) lstdt))
(setq lsttextvitri (vl-remove-if-not '(lambda (x) (= (cdr (assoc 8 (entget x))) "_VITRI_")) lstdt))
(setq lsttextcoc (vl-remove-if-not '(lambda (x) (= (cdr (assoc 8 (entget x))) "_TENCOT_")) lstdt))
(foreach line lstline
(setq point (cdr (assoc 10 (entget line))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 27.24))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object line) (vlax-3D-point point) (vlax-3D-point pointden))
)
(foreach textvt lsttextvitri
(setq point (cdr (assoc 10 (entget textvt))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 36))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object textvt) (vlax-3D-point point) (vlax-3D-point pointden))
)
(foreach textcoc lsttextcoc
(setq point (cdr (assoc 10 (entget textcoc))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 6))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object textcoc) (vlax-3D-point point) (vlax-3D-point pointden))
)
(princ)
)
(defun GetAngleVuong (obj pt)
(+ (angle pt (polar pt (angle '(0 0 0) (vlax-curve-getFirstDeriv obj (vlax-curve-getParamAtPoint obj pt))) 2)) (* pi 0.5))
)

 

  • Like 2

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
Vào lúc 16/6/2013 tại 15:20, Doan Van Ha đã nói:
16 phút trước, huunhantvxdts đã nói:

Gửi bạn nhé

lệnh MDT



(defun CV:ss-to-list (ss vla / n e l)
(if ss
(progn
(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))
)
)
)
) 
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)
(defun c:MDT (/ lstdt pl lstline lsttextvitri lsttextcoc point pointpl gocvuong pointden)
(setq lstdt (CV:ss-to-list (ssget '((0 . "TEXT,LINE"))) nil))
(setq pl (car (LM:SelectIf "\nChon duong Polyline:" (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))) 
															entsel nil)))
(setq lstline (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "LINE")) lstdt))
(setq lsttextvitri (vl-remove-if-not '(lambda (x) (= (cdr (assoc 8 (entget x))) "_VITRI_")) lstdt))
(setq lsttextcoc (vl-remove-if-not '(lambda (x) (= (cdr (assoc 8 (entget x))) "_TENCOT_")) lstdt))
(foreach line lstline
(setq point (cdr (assoc 10 (entget line))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 27.24))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object line) (vlax-3D-point point) (vlax-3D-point pointden))
)
(foreach textvt lsttextvitri
(setq point (cdr (assoc 10 (entget textvt))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 36))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object textvt) (vlax-3D-point point) (vlax-3D-point pointden))
)
(foreach textcoc lsttextcoc
(setq point (cdr (assoc 10 (entget textcoc))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 6))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object textcoc) (vlax-3D-point point) (vlax-3D-point pointden))
)
(princ)
)
(defun GetAngleVuong (obj pt)
(+ (angle pt (polar pt (angle '(0 0 0) (vlax-curve-getFirstDeriv obj (vlax-curve-getParamAtPoint obj pt))) 2)) (* pi 0.5))
)

 

 

16 phút trước, huunhantvxdts đã nói:

Gửi bạn nhé

lệnh MDT



(defun CV:ss-to-list (ss vla / n e l)
(if ss
(progn
(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))
)
)
)
) 
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)
(defun c:MDT (/ lstdt pl lstline lsttextvitri lsttextcoc point pointpl gocvuong pointden)
(setq lstdt (CV:ss-to-list (ssget '((0 . "TEXT,LINE"))) nil))
(setq pl (car (LM:SelectIf "\nChon duong Polyline:" (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))) 
															entsel nil)))
(setq lstline (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "LINE")) lstdt))
(setq lsttextvitri (vl-remove-if-not '(lambda (x) (= (cdr (assoc 8 (entget x))) "_VITRI_")) lstdt))
(setq lsttextcoc (vl-remove-if-not '(lambda (x) (= (cdr (assoc 8 (entget x))) "_TENCOT_")) lstdt))
(foreach line lstline
(setq point (cdr (assoc 10 (entget line))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 27.24))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object line) (vlax-3D-point point) (vlax-3D-point pointden))
)
(foreach textvt lsttextvitri
(setq point (cdr (assoc 10 (entget textvt))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 36))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object textvt) (vlax-3D-point point) (vlax-3D-point pointden))
)
(foreach textcoc lsttextcoc
(setq point (cdr (assoc 10 (entget textcoc))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 6))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object textcoc) (vlax-3D-point point) (vlax-3D-point pointden))
)
(princ)
)
(defun GetAngleVuong (obj pt)
(+ (angle pt (polar pt (angle '(0 0 0) (vlax-curve-getFirstDeriv obj (vlax-curve-getParamAtPoint obj pt))) 2)) (* pi 0.5))
)

 



 
;Doan Van Ha - CADViet.com - Ngay 16/6/2013
;Chuc nang: Move tung nhom doi tuong den 1 Lien.
(defun C:HA( / kieu typ lay ent ss p1 p2 pt z osm cmd)
 (command "undo" "be") (setq osm (getvar "osmode") cmd (getvar "cmdecho"))
 (initget "P TT TD 3")
 (setq kieu (getkword "\nKieu doi tuong can Move [point la P/text tren la TT/ text duoi la TD/tat ca la 3]: "))
 (cond
  ((= kieu "P") (setq typ "Point" lay "diem"))
  ((= kieu "TT") (setq typ "Text" lay "Tendiem"))
  ((= kieu "TD") (setq typ "Text" lay "Docao"))
  ((= kieu "3") (setq typ "Point,Text" lay "diem,Tendiem,Docao")))
 (if
  (and
   (setq ent (car (entsel "\nChon Line: ")))
   (princ "\nChon cac doi tuong can Move...")
   (setq ss (ssget (list (cons 0 typ) (cons 8 lay)))))
  (progn 
   (setvar "osmode" 0) (setvar "cmdecho" 0)
   (setq p1 (cdr (assoc 10 (entget ent))))
   (setq p2 (cdr (assoc 11 (entget ent))))
   (setq z -1)
   (repeat (sslength ss)
    (setq pt (cdr (assoc 10 (entget (ssname ss (setq z (1+ z)))))))
    (command "move" (ssname ss z) "" pt (FindPerpPoint p1 p2 pt)))))
 (setvar "osmode" osm) (setvar "cmdecho" cmd) (command "undo" "e") (princ))
(defun FindPerpPoint (p1 p2 q / x1 x2 x3 y1 y2 y3 z1 z2 z3 T4)
 (setq x1 (car p1) x2 (car p2) x3 (car q)
       y1 (cadr p1) y2 (cadr p2) y3 (cadr q)
       z1 (caddr p1) z2 (caddr p2) z3 (caddr q)
       T4 (/ (+ (* (- x2 x1) (- x3 x1)) (* (- y2 y1) (- y3 y1)) (* (- z2 z1) (- z3 z1)))
             (+ (* (- x2 x1) (- x2 x1)) (* (- y2 y1) (- y2 y1)) (* (- z2 z1) (- z2 z1)))))
 (list (+ x1 (* T4 (- x2 x1))) (+ y1 (* T4 (- y2 y1))) (+ z1 (* T4 (- z2 z1)))))

Cám Ơn Bác Nhiều !

 

 

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
19 phút trước, huunhantvxdts đã nói:

Gửi bạn nhé

lệnh MDT


(defun CV:ss-to-list (ss vla / n e l)
(if ss
(progn
(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))
)
)
)
) 
(defun LM:SelectIf ( msg pred func keyw / sel )
(setq pred (eval pred))
(while
(progn
(setvar 'ERRNO 0)
(if keyw (apply 'initget keyw))
(setq sel (func msg))
(cond
((= 7 (getvar 'ERRNO)) (princ "\nMissed, Try again."))
((eq 'STR (type sel)) nil)
((vl-consp sel) (if (and pred (not (pred sel))) (princ "\nInvalid Object Selected."))))))
sel)
(defun c:MDT (/ lstdt pl lstline lsttextvitri lsttextcoc point pointpl gocvuong pointden)
(setq lstdt (CV:ss-to-list (ssget '((0 . "TEXT,LINE"))) nil))
(setq pl (car (LM:SelectIf "\nChon duong Polyline:" (lambda (x) (eq "LWPOLYLINE" (cdr (assoc 0 (entget (car x)))))) 
															entsel nil)))
(setq lstline (vl-remove-if-not '(lambda (x) (= (cdr (assoc 0 (entget x))) "LINE")) lstdt))
(setq lsttextvitri (vl-remove-if-not '(lambda (x) (= (cdr (assoc 8 (entget x))) "_VITRI_")) lstdt))
(setq lsttextcoc (vl-remove-if-not '(lambda (x) (= (cdr (assoc 8 (entget x))) "_TENCOT_")) lstdt))
(foreach line lstline
(setq point (cdr (assoc 10 (entget line))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 27.24))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object line) (vlax-3D-point point) (vlax-3D-point pointden))
)
(foreach textvt lsttextvitri
(setq point (cdr (assoc 10 (entget textvt))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 36))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object textvt) (vlax-3D-point point) (vlax-3D-point pointden))
)
(foreach textcoc lsttextcoc
(setq point (cdr (assoc 10 (entget textcoc))))
(setq pointpl (vlax-curve-getClosestPointTo pl point))
(setq gocvuong (GetAngleVuong pl pointpl))
(setq pointden (polar pointpl gocvuong 6))
;(setq newobj (vla-copy (vlax-ename->vla-object dtcp)))
(vla-move (vlax-ename->vla-object textcoc) (vlax-3D-point point) (vlax-3D-point pointden))
)
(princ)
)
(defun GetAngleVuong (obj pt)
(+ (angle pt (polar pt (angle '(0 0 0) (vlax-curve-getFirstDeriv obj (vlax-curve-getParamAtPoint obj pt))) 2)) (* pi 0.5))
)

 

Em Cảm Ơn Bác Nhiều! CHúc bác và Gia đình Mạnh Khỏe và Hạnh Phú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

Tạo một tài khoản hoặc đăng nhập để nhận xét

Bạn cần phải là một thành viên để lại một bình luận

Tạo tài khoản

Đăng ký một tài khoản mới trong cộng đồng của chúng tôi. Điều đó dễ mà.

Đăng ký tài khoản mới

Đăng nhập

Bạn có sẵn sàng để tạo một tài khoản ? Đăng nhập tại đây.

Đăng nhập ngay

×