Chuyển đến nội dung
Diễn đàn CADViet
dauquangminh

[Yêu cầu] Lisp tính lý trình các điểm trên 1 polyline/line

Bởi dauquangminh , trong AutoLisp

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

mathan    60

mathan
Đã đăng

Hề hề hề

Phải chăng bạn cần cái này:

Hề hề hề.

@ phamxuanly gtvt: hãy gửi bản vẽ bị lỗi lên...

@ Bác Bình: Tôi cũng đã một số lisp lý trình, nhưng có cách nào để pick vào 1 điểm ngoài đường Pline tim mà nó vẫn nhận ra lý trình được không bá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

mathan    60

mathan
Đã đăng

Cảm ơn phamthanhbinh nhiều nhé. Em dùng thấy nó thật là ngon.

Bác cho e mượn cái code xào nấu thêm chút đỉnh cho theo ý nha.

Thank bác. nhiều nhé. Em dùng thấy ngon lắmnhêề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

phamthanhbinh    3.146

phamthanhbinh
Đã đăng

líp bi lỗi rồi bác bình ơi, mình thử dùng mà không được, nhờ bác xem hộ!

Hề hề hề,

Bác ơi em ốm, bác cứu em với !!!!!

Nhưng mà cứu thế nào khi chả biết em bị bệnh gì, sốt bao nhiêu độ, ăn được cái gì, uống được cái chi, gãy tay hay què cẳng ????

vậy nên nếu em muốn bác coi lại thì em phải nói cái lỗi nó như thế nào. CAD trả về cái gì khi chạy thì mới nói chuyện xem chứ. Bởi vì cái đó chủ thớt đã dùng và một vài người nữa cũng đả test chứ không phải mình quăng ẩu lên đâu.

Ấy là chưa kể em có hiểu mục đích sử dụng của lisp hay không vì: phúc thống mà phục nhân sâm thì tắc tử đó em ơi.

Hề hề hề.....

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

trieubb    5

trieubb
Đã đăng

Hề hề hề

Phải chăng bạn cần cái này:


(defun c:glt (/ pl plst pa pd k l ltg p0 a lt lt1 lt2 txt tg etg txtp txtp1 txtp2 dl dl1 dl2)
(vl-load-com)
(command "undo" "be")
(setq ucsold (getvar "ucsname"))
(command "ucs" "w")
(setq pl (car (entsel "\n Chon polyline can ghi ly trinh")))
(setq plst (vl-sort (acet-geom-vertex-list pl) '(lambda (x y) (< (car x) (car y)))))
(setq pa (getstring t "\n Chon chieu ghi ly trinh <T or P>: "))
(if (= (strcase pa) "T")
   (setq pd (car plst))
   (setq pd (last plst))
)
(setq p0 (getpoint "\n Chon diem goc ghi ly trinh"))
(setq ltg (getreal "\n Nhap ly trinh goc: "))        
(setq k (getint "\n Chon so chu so thap phan: "))
(setq l (getint "\n Chon phuong an ghi ly trinh <1 or 2>: "))
(setq a (getpoint "\n Chon point can ghi ly trinh"))
(while ( /= a nil)
(if (= l 1)
   (progn
         (if (equal (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object pl))) pd 0.001)
             (setq lt (+ (- (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))
                              	(vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))  ) ltg )  )
             (setq lt (+ (- (vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))
                              	(vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))
                                	) ltg )  )
         )
         (setq dl (abs (- lt (* (fix (/ lt 1000)) 1000))))
         (if (< (fix dl) 100)
             (if (< (fix dl) 10)
                 (setq txtp (strcat "00" (rtos dl 2 k)))
                 (setq txtp (strcat "0" (rtos dl 2 k)))
             )
             (setq txtp (rtos dl 2 k))
         )
         (if (> lt 0)
             (setq txt (strcat "Km" (itoa (fix (/ lt 1000))) "+" txtp))
             (setq txt (strcat "Km" (itoa (fix (/ lt 1000))) "-" txtp))
         )
         (setq tg (car (entsel "\n Chon text can thay the ")))
         (setq etg (entget tg))
         (setq etg (subst (cons 1 txt) (assoc 1 etg) etg))
         (entmod etg)
   )
   (progn
    	(if (equal (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object pl))) pd 0.001)
        	(progn
                 (setq lt1 (+ (- (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))
                                    	(vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))  ) ltg )  )
                 (setq lt2 (+ (- (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon second point can ghi ly trinh")))
                                    	(vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))  ) ltg ))
        	)
        	(progn
            	(setq lt1 (+ (- (vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))
                                       (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))  ) ltg ))
            	(setq lt2 (+ (- (vlax-curve-getdistatpoint obj (vlax-curve-getclosestpointto obj p0))
                                       (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon second point can ghi ly trinh"))) ) ltg ))
        	)
         )
         (setq dl1 (abs (- lt1 (* (fix (/ lt1 1000)) 1000))))
         (if (< (fix dl1) 100)
             (if (< (fix dl1) 10)
                 (setq txtp1 (strcat "00" (rtos dl1 2 k)))
                 (setq txtp1 (strcat "0" (rtos dl1 2 k)))
             )
             (setq txtp1 (rtos dl1 2 k))
         )
         (setq dl2 (abs (- lt2 (* (fix (/ lt2 1000)) 1000))))
         (if (< (fix dl2) 100)
             (if (< (fix dl2) 10)
                 (setq txtp2 (strcat "00" (rtos dl2 2 k)))
                 (setq txtp2 (strcat "0" (rtos dl2 2 k)))
             )
             (setq txtp2 (rtos dl2 2 k))
         )
         (if (and (>=  lt1 0) (>=  lt2 0))
          	(setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "+" txtp1 "-Km" (itoa (fix (/ lt2 1000))) "+" txtp2 )))
         (if (and (>=  lt1 0) (<  lt2 0))
             (setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "+" txtp1 "-Km" (itoa (fix (/ lt2 1000))) "-" txtp2 )))
         (if (and (<  lt1 0) (>=  lt2 0))
          	(setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "-" txtp1 "-Km" (itoa (fix (/ lt2 1000))) "+" txtp2 )))
         (if (and (<  lt1 0) (<  lt2 0))
          	(setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "-" txtp1 "-Km" (itoa (fix (/ lt2 1000))) "-" txtp2 )))
         (setq tg (car (entsel "\n Chon text can thay the ")))
         (setq etg (entget tg))
         (setq etg (subst (cons 1 txt) (assoc 1 etg) etg))
         (entmod etg)
	)
)
(setq a (getpoint "\n Ban hay chon diem tiep theo: "))
)
(if (/= ucsold "")
   (command "ucs" "p")
)
(command "undo" "e")
(princ)
)

Hề hề hề.

@ phamxuanly gtvt: hãy gửi bản vẽ bị lỗi lên...

 

 

 

Kính chuyển bác phamthanhbinh lisp của bác khi chọn lý trình gốc là 0 thì tại 1000m ghi là Km1+000, 2000m ghi là Km2+000, 3000m ghi là Km3+000 thì ok, nhưng đến 4000m nó lại ghi là Km3+1000 bác xem lại nhé

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

Tu Mo    0

Tu Mo
Đã đăng
Vào lúc 10/9/2011 tại 15:49, phamthanhbinh đã nói:

Xin chào,

Bạn dùng thử cái này xem đã ưng ý chưa nhé. Nếu cần gì bổ sung thì hãy post lên

  


(defun c:glt (/ pl plst pa pd k l a lt lt1 lt2 txt tg etg)
(vl-load-com)
(command "undo" "be")
(setq pl (car (entsel "\n Chon polyline can ghi ly trinh")))
(setq plst (vl-sort (acet-geom-vertex-list pl) '(lambda (x y) (< (car x) (car y)))))
(setq pa (getstring t "\n Chon diem goc ghi ly trinh <T or P>: "))
(if (= (strcase pa) "T")
   (setq pd (car plst))
   (setq pd (last plst)))
(setq k (getint "\n Chon so chu so thap phan: "))
(setq l (getint "\n Chon phuong an ghi ly trinh <1 or 2>: "))
(setq a "Y")
(while (= (strcase a) "Y")
(if (= l 1)
   (progn
         (if (equal (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object pl))) pd 0.001)
             (setq lt (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon point can ghi ly trinh"))))
             (setq lt (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
                    		(vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon point can ghi ly trinh")))))
         )
         (setq txt (strcat "Km" (itoa (fix (/ lt 1000))) "+" (rtos (- lt (fix (/ lt 1000))) 2 k)))
         (setq tg (car (entsel "\n Chon text can thay the ")))
         (setq etg (entget tg))
         (setq etg (subst (cons 1 txt) (assoc 1 etg) etg))
         (entmod etg)
   )
   (progn
		(if (equal (vlax-curve-getStartPoint (setq obj (vlax-ename->vla-object pl))) pd 0.001)
    		(progn
                 (setq lt1 (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon first point can ghi ly trinh"))))
                                (setq lt2 (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon second point can ghi ly trinh"))))
    		)
    		(progn
        		(setq lt1 (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
                                 (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon first point can ghi ly trinh")))))
        		(setq lt2 (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
                                 (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon second point can ghi ly trinh")))))
    		)
         )
         (setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "+" (rtos (- lt1 (fix (/ lt1 1000))) 2 k) 
                              "-Km" (itoa (fix (/ lt2 1000))) "+" (rtos (- lt2 (fix (/ lt2 1000))) 2 k) ))
         (setq tg (car (entsel "\n Chon text can thay the ")))
         (setq etg (entget tg))
         (setq etg (subst (cons 1 txt) (assoc 1 etg) etg))
         (entmod etg)
)
)
(setq a (getstring "\n Ban muon tiep tuc khong <Y or N>: ")))
(command "undo" "e")
(princ))
 

 

Chúc bạn vui

Bác PhamThanhBinh cho e hỏi giờ e không muốn thay thế txt mà ghi rõ ra text (điểm nào ghi ra điểm đó) thì chỉnh lisp thế nào ạ?, Mong bác hồi đáp, em xin cảm ơn bá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
Về Đầu Trang AutoLisp
×