Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
30 replies to this topic

#1 dauquangminh

dauquangminh

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 36 (tàm tạm)

Đã gửi 29 August 2011 - 05:50 PM

(Yêu cầu của Lisp đã sửa lại cho đơn giản hơn, mong các bác giúp đỡ:

Lisp sẽ đo chiều dài từ điểm đầu đến 1 hoặc 2 điểm được pick trên 1 polyline hoặc 1 line và điền vào 1 text có sẵn như hình vẽ:
Hình đã gửi

Hình đã gửi
Lisp sẽ hỏi như sau:
- Chọn line/polyline cần tính lý trình:
- Điểm đầu nằm bên trái (T) hay phải (P): nếu gõ T tức điểm đầu là điểm A, còn gõ P tức điểm đầu là điểm B
- Làm tròn sau dấu chấm mấy con số: ví dụ là 2
- Tính lý trình của 1 hay 2 điểm:
(Nếu ta chọn 1 thì lisp sẽ hỏi tiếp như sau:)

- Pick điểm thứ nhất cần tính lý trình: ví dụ ta chọn điểm 1
- Chọn text để điền kết quả:
(Nếu ta chọn 2 thì lisp sẽ hỏi tiếp như sau:)


- Pick điểm thứ nhất cần tính lý trình: ví dụ ta chọn điểm 1
- Pick điểm thứ hai cần tính lý trình: ví dụ ta chọn điểm 2
- Chọn text để điền kết quả:

Kết quả 1 sẽ chạy ra như hình vẽ
- Pick điểm thứ nhất cần tính lý trình: ví dụ ta chọn điểm 3
- Pick điểm thứ hai cần tính lý trình: ví dụ ta chọn điểm 4
- Chọn text để điền kết quả:

Kết quả 2 sẽ chạy ra như hình vẽ
… cứ như thế… khi nào tính xong thì nhấn Enter để kết thúc lisp.

Lưu ý: Kết quả chạy ra có một số đặc điểm sau:
- Text sau khi điền kết quả vẫn giữ nguyên tất cả các thuộc tính về layer, màu sắc, đường nét, góc ... như cũ
- Khi tính lý trình của 1 điểm thì kết quả sẽ có dạng "Km0+024.74"
- Khi tính lý trình của 2 điểm thì kết quả sẽ có dạng "Km0+024.74-Km0+036.21"

Trong cụm text "Km0+024.74-Km0+036.21" hay "Km0+024.74" thì "Km","+","-" không đổi, chỉ các con số như "0"," 024.74"… thay đổi theo khoảng cách lisp đo được từ điểm đầu đến điểm 1 và 2
Ví dụ đo được "24.74" thì lisp sẽ ghi là "Km0+024.74"
Ví dụ đo được "124.74" thì lisp sẽ ghi là "Km0+124.74"
Ví dụ đo được "1124.74" thì lisp sẽ ghi là "Km1+124.74"
(làm tròn: lấy theo số liệu người dùng đã nhập ở trên, phần "Làm tròn sau dấu chấm mấy con số:" )

Cảm ơn các bác rất nhiều. Yêu cầu đã được đơn giản bớt. Mong giúp đỡ. Nếu các bác thấy dài quá thì cứ nói, em sẽ bỏ thêm nữa
  • 0

#2 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 30 August 2011 - 10:17 AM

Mình hỏi ngoài lề chút : dài như thế thì liệu có thù lao không :blush:
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#3 dauquangminh

dauquangminh

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 36 (tàm tạm)

Đã gửi 30 August 2011 - 08:30 PM

Mình hỏi ngoài lề chút : dài như thế thì liệu có thù lao không :blush:


Hix. Bác cần gì sẽ có cái đó, tất nhiên chỉ trong khả năng của em.
^_^
  • 0

#4 dauquangminh

dauquangminh

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 36 (tàm tạm)

Đã gửi 01 September 2011 - 09:09 PM

topic bị bỏ rơi. hix. buồn quá. :mellow:
hay là yêu cầu dài quá nhỉ
  • 0

#5 dauquangminh

dauquangminh

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 36 (tàm tạm)

Đã gửi 08 September 2011 - 02:37 PM

em đã bỏ bớt một số yêu cầu của lisp cho đơn giản hơn. Mong các bác giúp đỡ.
  • 0

#6 ketxu

ketxu

    Copier - Paster - Editor

  • Moderator
  • PipPipPipPipPipPipPip
  • 5678 Bài viết
Điểm đánh giá: 2605 (tuyệt vời)

Đã gửi 08 September 2011 - 10:08 PM

Yêu cầu của bạn không phải là khó, tuy nhiên chắc còn ít người hứng thú vì nó rườm rà quá :) Lần này có lẽ sẽ khả thi hơn. Chúc bạn may mắn
  • 0

Thành viên nhóm CadMagic.
Mời bạn ghé thăm facebook nhóm - Page viết lisp theo yêu cầu  :
CAD MAGIC


#7 dauquangminh

dauquangminh

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 36 (tàm tạm)

Đã gửi 10 September 2011 - 09:26 AM

em đã sửa lại yêu cầu lần 2, chắc chắn ngắn gọn hơn. Mong các bác giúp đỡ
  • 0

#8 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 10 September 2011 - 03:49 PM

em đã sửa lại yêu cầu lần 2, chắc chắn ngắn gọn hơn. Mong các bác giúp đỡ

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
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#9 thanhduan2407

thanhduan2407

    biết lệnh adcenter

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

Đã gửi 10 September 2011 - 04:07 PM

Bác Bình thật là nhanh. Lần trước em viết bảo nhờ bác Bình hoặc bác ketxu thì ok lâu rồi nhưng mạng lỗi nên ko up lên dc. Hiii. Cái này có phần thưởng thì phải. Hề hề hề
  • 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







#10 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 10 September 2011 - 05:02 PM

Bác Bình thật là nhanh. Lần trước em viết bảo nhờ bác Bình hoặc bác ketxu thì ok lâu rồi nhưng mạng lỗi nên ko up lên dc. Hiii. Cái này có phần thưởng thì phải. Hề hề hề

Hề hề hề,
Thực ra cái này là mình viết vội thôi chứ chưa hoàn toàn thỏa mãn yêu cầu của chủ thớt đâu. Mình biết vậy nhưng cứ gửi lên để chủ thớt tham khảo rồi sửa chữa gì đó thì tùy ý. Thực tình mình không thích cái cách chủ thớt ra đề, Vì làm như vầy chứng tỏ chủ thớt chỉ muốn mọi người làm theo ý chủ thớt mà phàm những gì cứ phải dập khuôn theo một cái mẫu thi chán chết, chả còn tí tự do sáng tạo gì nữa cả. Nhất là nhiều khi ý tưởng của chủ thớt đưa ra lại chưa phải là tối ưu nữa.
Hơn nữa việc chủ thớt có thể phân tích tỉ mỉ từng bước như vầy chứng tỏ chủ thớt cũng khá am tường về lisp, vậy mà sao không cố một tí để làm mà cứ phải đi cầu cứu như vầy. Thiệt là thụ động lắm lắm.
Mình viết như vầy để xem ý chủ thớt ra răng rồi mới làm kỹ hơn....
Hề hề hề,....
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#11 dauquangminh

dauquangminh

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 36 (tàm tạm)

Đã gửi 10 September 2011 - 08:44 PM

cảm ơn bác phamthanhbinh về ý kiến đóng góp. em sẽ rút kinh nghiệm tập 1
em phân tích tỉ mỉ như vậy chẳng qua là do em đã dùng nhiều lisp thôi, chứ em có biết gì về viết lisp đâu
Mục đích em lập topic này là để có 1 lisp dùng riêng cho giao thông, tuy nhiên nó lại quá rườm rà, làm cho các anh chị khó chịu, thật tình xin lỗi các anh chị.

Em muốn bác binh sửa giúp 2 chỗ ạ:
1. Xóa chỗ "Bạn muốn tiếp tục không <Y or N>", tức để mặc định là có (Y), không cần hỏi đâu ạ, nếu không muốn tiếp tục nữa thì chỉ cần nhấn enter là xong,
2. đối với chiều dài có 4 con số trở lên thì lisp chạy sai ạ, ví dụ:
dài 1000 thì đúng ra lisp phải ghi là Km1+000, nhưng nó lại ghi là Km1+999
dài 5555 thì đúng ra lisp phải ghi là Km5+555, nhưng nó lại ghi là Km5+5550

cảm ơn bác binh
  • 0

#12 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 11 September 2011 - 10:18 PM

cảm ơn bác phamthanhbinh về ý kiến đóng góp. em sẽ rút kinh nghiệm tập 1
em phân tích tỉ mỉ như vậy chẳng qua là do em đã dùng nhiều lisp thôi, chứ em có biết gì về viết lisp đâu
Mục đích em lập topic này là để có 1 lisp dùng riêng cho giao thông, tuy nhiên nó lại quá rườm rà, làm cho các anh chị khó chịu, thật tình xin lỗi các anh chị.

Em muốn bác binh sửa giúp 2 chỗ ạ:
1. Xóa chỗ "Bạn muốn tiếp tục không <Y or N>", tức để mặc định là có (Y), không cần hỏi đâu ạ, nếu không muốn tiếp tục nữa thì chỉ cần nhấn enter là xong,
2. đối với chiều dài có 4 con số trở lên thì lisp chạy sai ạ, ví dụ:
dài 1000 thì đúng ra lisp phải ghi là Km1+000, nhưng nó lại ghi là Km1+999
dài 5555 thì đúng ra lisp phải ghi là Km5+555, nhưng nó lại ghi là Km5+5550

cảm ơn bác binh

Hề hề hề,
Xin lỗi bạn vì mình đã không check lisp cẩn thận.
1/- Về cái yêu cầu thứ hai lỗi là ở các dòng code:
(setq txt (strcat "Km" (itoa (fix (/ lt 1000))) "+" (rtos (- lt (fix (/ lt 1000))) 2 k)))

(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) ))
Bạn hãy sửa chúng lại như sau:
(setq txt (strcat "Km" (itoa (fix (/ lt 1000))) "+" (rtos (- lt (* (fix (/ lt 1000)) 1000)) 2 k)))


(setq txt (strcat "Km" (itoa (fix (/ lt1 1000))) "+" (rtos (- lt1 (* (fix (/ lt1 1000)) 1000)) 2 k) "-Km" (itoa (fix (/ lt2 1000))) "+" (rtos (- lt2 (* (fix (/ lt2 1000)) 1000)) 2 k) ))

2/- Còn về yêu cầu thứ hai bạn hãy sửa các dòng code sau:
(setq a "Y") thành (setq a (getpoint "\n Chon point can ghi ly trinh"))
(while (= (strcase a) "Y") thành (while ( /= a nil)
(setq lt (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon point can ghi ly trinh")))) thành (setq lt (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a)))
(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"))))) thành (setq lt (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj)) (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))))
(setq lt1 (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj (getpoint "\n Chon first point can ghi ly trinh")))) thành (setq lt1 (vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a)))
(setq a (getstring "\n Ban muon tiep tuc khong <Y or N>: "))) thành (setq a (getpoint "\n Ban hay chon diem tiep theo: ")))

3/- Thực ra còn một điều mình chưa làm đó là với các số lẻ sau số Km, nếu chúng ít hơn 3 chữ số thì phải thêm các chữ số 0 vào phía trước cho đủ 3 chữ số như hình bạn đã post. Điều này tuy không khó nhưng mình thấy không cần thiết lắm và nghĩ rằng bạn có đủ khả năng để làm nên mình để vậy. Nếu thực sự điều đó là cần mình sẽ bổ sung sau bạn nhé.

Chúc bạn vui.
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#13 dauquangminh

dauquangminh

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 36 (tàm tạm)

Đã gửi 12 September 2011 - 10:43 AM

"3/- Thực ra còn một điều mình chưa làm đó là với các số lẻ sau số Km, nếu chúng ít hơn 3 chữ số thì phải thêm các chữ số 0 vào phía trước cho đủ 3 chữ số như hình bạn đã post. Điều này tuy không khó nhưng mình thấy không cần thiết lắm và nghĩ rằng bạn có đủ khả năng để làm nên mình để vậy. Nếu thực sự điều đó là cần mình sẽ bổ sung sau bạn nhé."


Em cần cái này bác à. Trưởng phòng em ổng kỹ tính lắm, ổng bắt sửa cho đến khi nào đúng ý ổng mới chịu.
mặt khác: đo được 1000 thì lisp ghi là "Km1+0", đo được 10000 thì lisp ghi là "Km10+0", em thấy "Km1+000", "Km10+000" có vẻ đồng bộ hơn ạ, và bên đường giao thông tụi em toàn ghi kiểu này. Vậy nên nhờ bác sửa giùm cái vụ con số 0 này cho đủ 3 chữ số ạ.
  • 0

#14 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 12 September 2011 - 03:32 PM

"3/- Thực ra còn một điều mình chưa làm đó là với các số lẻ sau số Km, nếu chúng ít hơn 3 chữ số thì phải thêm các chữ số 0 vào phía trước cho đủ 3 chữ số như hình bạn đã post. Điều này tuy không khó nhưng mình thấy không cần thiết lắm và nghĩ rằng bạn có đủ khả năng để làm nên mình để vậy. Nếu thực sự điều đó là cần mình sẽ bổ sung sau bạn nhé."


Em cần cái này bác à. Trưởng phòng em ổng kỹ tính lắm, ổng bắt sửa cho đến khi nào đúng ý ổng mới chịu.
mặt khác: đo được 1000 thì lisp ghi là "Km1+0", đo được 10000 thì lisp ghi là "Km10+0", em thấy "Km1+000", "Km10+000" có vẻ đồng bộ hơn ạ, và bên đường giao thông tụi em toàn ghi kiểu này. Vậy nên nhờ bác sửa giùm cái vụ con số 0 này cho đủ 3 chữ số ạ.

Hề hề hề,
Của bạn đây. Hy vọng bạn sẽ hài lòng với lần sửa này;


(defun c:glt (/ pl plst pa pd k l a lt lt1 lt2 txt tg etg txtp txtp1 txtp2 dl dl1 dl2)
(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 (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)))
(setq lt (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
(vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))))
)
(setq dl (- 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))
)
(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)))
(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 a))))
(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 dl1 (- 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 (- 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))
)
(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: "))
)
(command "undo" "e")
(princ)
)
Chúc bạn luôn vui khi tham gia diễn đàn cùng mọi người.
  • 1
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#15 dauquangminh

dauquangminh

    biết vẽ arc

  • Members
  • PipPip
  • 41 Bài viết
Điểm đánh giá: 36 (tàm tạm)

Đã gửi 12 September 2011 - 07:54 PM

Vâng. Em hài lòng rồi. Cảm ơn bác.
Liệu em có thể chia sẻ lisp này cho các diễn đàn khác được không ạ, tất nhiên em sẽ đề tên của bác là tác giả.
Hậu tạ bác như thế nào đây ạ?
  • 0

#16 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 12 September 2011 - 11:31 PM

Vâng. Em hài lòng rồi. Cảm ơn bác.
Liệu em có thể chia sẻ lisp này cho các diễn đàn khác được không ạ, tất nhiên em sẽ đề tên của bác là tác giả.
Hậu tạ bác như thế nào đây ạ?

Hề hề hề,
Đây là diễn đàn mở mà. bạn cứ việc chia sẻ thoải mái ở bất cứ đâu mà bạn thấy yên tâm với những điều bạn làm. Việc để tên tác giả là mình hay bạn chả quan trọng gì đâu vì bản thân mình cũng còn đang đi mót thấy ông bà ông vải chứ đã ăn thua chi mà đeo râu hay đội mũ.
Hậu tạ làm chi khi mà cái tiền tạ chửa có. Hề hề hề,.....
Chỉ e rằng đến lúc hậu .......sự thì chẳng còn ai thôi. Hề hề hề,....
  • 0
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.

#17 thanhduan2407

thanhduan2407

    biết lệnh adcenter

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

Đã gửi 12 September 2011 - 11:48 PM

Bác Bình đừng nói cho ai biết là em là nhà tiên tri nhé. ;). Vì em đoán thế nào bác chẳng ra tay giúp bạn này. Cái của bác mót được mà giúp mọi người thì em cũng muốn. Hiii. Em đi ctr nên chắc chỉ đá đưa thôi chứ hổng thể viết được. Hii.
Bạn gì muốn hậu tạ thì ok, khi nào mời bác ấy đi 1 chầu bia là ok ấy mà. Hee
  • 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







#18 duyngoc

duyngoc

    biết vẽ pline

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

Đã gửi 25 October 2011 - 03:03 PM

Hề hề hề,
Của bạn đây. Hy vọng bạn sẽ hài lòng với lần sửa này;



(defun c:glt (/ pl plst pa pd k l a lt lt1 lt2 txt tg etg txtp txtp1 txtp2 dl dl1 dl2)
(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 (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)))
(setq lt (- (vlax-curve-getDistAtPoint obj (vlax-curve-getEndPoint obj))
(vlax-curve-getDistAtPoint obj (vlax-curve-getClosestPointTo obj a))))
)
(setq dl (- 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))
)
(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)))
(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 a))))
(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 dl1 (- 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 (- 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))
)
(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: ")))
)
(command "undo" "e")
(princ)
)
Chúc bạn luôn vui khi tham gia diễn đàn cùng mọi người.

Mình thấy lisp của bạn PhamThanhBinh rất hay, tuy nhiên nếu sửa lại như thế này thì hay biết mấy: Sau khi gõ lệnh GLT thì lisp nên hỏi chọn điểm gốc để tính lý trình, lý trình điểm gốc là bao nhiêu? để điền cho đúng.

Bài viết đã được chỉnh sửa nội dung bởi duyngoc: 25 October 2011 - 03:08 PM

  • 0

#19 phamxuanly.gtvt

phamxuanly.gtvt

    biết zoom

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

Đã gửi 04 November 2011 - 10:53 PM

Lisp bị lỗi rồi anh ơi, em làm đi làm lại mấy lần rồi, nó không ra lý trình tại điểm mình pick, mà nó ra lý trình toàn tuyến thôi. anh check lại thư nha anh!!!
  • 0

#20 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

  • Moderator
  • PipPipPipPipPipPipPip
  • 6007 Bài viết
Điểm đánh giá: 3113 (tuyệt vời)

Đã gửi 05 November 2011 - 04:56 PM

Mình thấy lisp của bạn PhamThanhBinh rất hay, tuy nhiên nếu sửa lại như thế này thì hay biết mấy: Sau khi gõ lệnh GLT thì lisp nên hỏi chọn điểm gốc để tính lý trình, lý trình điểm gốc là bao nhiêu? để điền cho đú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...

Bài viết đã được chỉnh sửa nội dung bởi phamthanhbinh: 08 November 2011 - 02:42 PM
Sửa lại và bổ sung lisp theo ý kiến của bạn PhamxuanLy gtvt

  • 3
Chúc các quý Anh trên diễn đàn luôn khỏe, đẻ thêm được nhiều thứ để mót.