Giúp sửa lisp ghi lý trình tuyến!

[mourison1993 7]

Mình có lisp sưu tầm trên mạng và nhờ ChatGPT chỉnh sửa dần cũng được 90% theo ý muốn rồi, còn 1 vấn đề nhỏ là khi rải lý trình trên tuyến thì cọc đầu và cọc cuối không có, mình muốn thêm vào cọc đầu là Km0+000 và cọc cuối sẽ theo chiều dài của đường Polyline, rất mong các bác giúp e chỉnh sửa thêm cho hoàn thiện ạ, e cám ơn!

Nội dung lisp (e không chèn file đính kèm được):

(defun C:RLT()
  (RDInput1)
  (RDSA)
)

(defun C:RDS1()
  (RDSA)
)

(defun RDSA ()
  (setq cmdold (getvar "cmdecho"))
  (setvar "cmdecho" 0)           
  (setq osmold (getvar "osmode"))
  (setvar "osmode" 0)
  (princ) (terpri)

  (setq sst nil)
  (while (= sst nil) 
    (setq sst (entsel "\nChọn tim tuyến:"))
  )

  (setq RD (+ RD rdi)) ; First Value
  (COMMAND "MEASURE" sst "B" rdmB "" mdi)
  (COMMAND "MEASURE" sst "B" "RD" "" rdii)
  (setq SSET (ssget "P")) 

  (setq COUNT 0)
  (while (< COUNT (sslength SSET))
    (setq A1 (ssname SSET count))
    (setq A2 (entget A1))
    (setq A3 (cdr (assoc 0 A2)))
    (if (= A3 "INSERT")
      (progn
        (setq A4 (assoc 10 A2))
        (setq A5 (cdr A4)) 
        (command "EXPLODE" a1)
        (SETQ X1 (ENTGET(ENTLAST)))
        (SETQ X2 (ASSOC 1 X1))
        (SETQ X3 (CDR X2))
        (SETQ RD5 (RTOS RD 2 0))
        (setq RDtxt RD5)
        (text1)
        (setq B1 RDtext)    
        (setq B2 (cons 1 B1))
        (setq A2 (subst B2 X2 X1))
        (entmod A2)
        (SETQ RD5 (ATOF RD5))
        (SETQ RD (+ RD5 rdi))
      )
    )
    (setq count (+ 1 count))
  )
  (setvar "cmdecho" cmdold)
  (setvar "osmode" osmold)
  (terpri)
  (princ (strcat " RD  = " (rtos rd 2 0))) (terpri)
)

(defun text1 (/ abs2 rem1)
  (if (and (= (strlen RDtxt) 1) (= RDtxt "0"))
    (Progn      
      (setq RDtxt "0000")
    )                                               
    (progn                                                                 
      (if (and (> (strlen RDtxt) 1) (<= (strlen RDtxt) 3))           
        (setq RDtxt (strcat "0" RDtxt))
      )                                   
    )                                                                     
  )
  (setq abs2 (substr RDtxt 1 (- (strlen RDtxt) 3)))         
  (setq rem1 (substr RDtxt (+ (strlen abs2) 1)))             
  (setq RDtext (strcat "Km" abs2 "+" rem1))
)

(defun c:RDInput ()
  (RDInput1)
)

(defun c:RD ()
  (RD1)
)

(defun c:RDI()
  (RDI1)
)

(defun c:RDM()
  (RDM1)
)

(defun c:RDMB()
  (RDMB1)
)

(defun c:SF()
  (SF1)
)

(defun RDInput1 ()
  (SF1) ; Scale Factor
  (RD1) ; RD # and block
  (RDblk) 
  (RDI1) ; RD interval
  (RDM1) ; RD marker Interval 
  (RDMB1) ; RD marker block name
)

(defun RD1 (/ RD1)
  (if (= RD nil) (setq RD 0))
  (setq RD1  (getreal (strcat "\nLý trình bắt đầu #  [" (rtos RD 2 0) "] :")))
  (if (/= RD1 nil) (setq RD RD1))
  (princ (strcat "RD = " (rtos rd 2 0))) (terpri)
)

(defun RDI1(/ rdiA)
  (if (= rdi nil) (setq rdi 100))
  (setq rdiA (getreal (strcat "\nNhập khoảng cách điền tên cọc:  [" (rtos RDi 2 0) "] :")))
  (if (/= rdiA nil) (setq rdi rdiA))
  (princ (strcat "RD Intr =  " (rtos rdi 2 0))) (terpri)
  (setq rdii (* rdi ssf))
)

(defun RDM1(/ mdA)
  (if (= md nil) (setq md 100))
  (setq mdA (getreal (strcat "\nNhập khoảng cách rãi cọc:  [" (rtos md 2 0) "] :" )))
  (if (/= mdA nil) (setq md mdA))
  (if (> md rdi) (setq md rdi))
  (princ (strcat "RD marker Dist = " (rtos md 2 0))) (terpri)
  (setq mdi (* md ssf))
)

(defun RDMB1()
  (if (= rdmB nil) (setq rdmB " "))
  (setq rdmB (getstring (strcat "\nĐặt tên block cọc: [" rdmB "]:")))
  (while (equal rdmB "")
    (setq rdmB (getstring (strcat "\nĐặt tên block cọc: [" rdmB "]:")))
  )
  (princ (strcat "RD marker Blk = " rdmB))
  (RDmarker)             ; RD marker Block
)

(defun SF1(/ ssf1)
  (if (= ssf nil) (setq ssf 1.0))
  (setq ssf1 (getreal (strcat "\nNhập tỉ lệ rãi: [" (rtos ssf 2 8) "] :")))
  (if (/= ssf1 nil) (setq ssf ssf1))
  (princ (strcat "Sheet Scale Factor = " (rtos ssf 2 8))) (terpri)
)

(defun RDblk(/ sl curlyr osmold list1 yCoord)
  (setvar "cmdecho" 0)  ; Tắt echo trong command line
  (setq osmold (getvar "osmode"))  ; Lưu trạng thái hiện tại của osmode
  (setvar "osmode" 0)  ; Tắt chế độ chọn đối tượng mặc định

  ; Yêu cầu người dùng nhập chiều cao của block
  (setq height (getreal "\nNhập chiều cao chữ: ")) ; Yêu cầu nhập chiều cao

  ; Yêu cầu người dùng nhập giá trị tọa độ Y cho block
  (setq yCoord (getreal "\nNhập khoảng cách cọc so với tim: [mặc định: -25]:"))
  (if (null yCoord) (setq yCoord -25))  ; Nếu người dùng không nhập gì, mặc định tọa độ là -25

  ; Kiểm tra xem block "RD" đã tồn tại hay chưa
  (if (equal (tblsearch "block" "RD") nil) (progn
    (command "zoom" "e")  ; Phóng to toàn bộ bản vẽ
    (command "style" "ghc" "Arial" "0.0" "1.0" "0" "N" "N")  ; Cài đặt kiểu chữ
    (command "color" "green")  ; Đặt màu sắc cho văn bản
    (command "TEXT" "S" "ghc" "J" "ML" "0,0" height "90" "Km0+000")  ; Vẽ văn bản Km0+000
    (setq list1 (list (cons 0 "TEXT")(cons 1 "Km0+000")))  ; Tạo đối tượng văn bản
    (setq sl (ssget "l" list1))  ; Lấy danh sách đối tượng văn bản
    ; Tạo block "RD" tại tọa độ (0, yCoord)
    (command "block" "RD" (strcat "0," (rtos yCoord 2 0)) sl "")
  ))

  ; Khôi phục trạng thái cũ của osmode
  (setvar "osmode" osmold)
  ; Phóng to lại phạm vi ban đầu
  (command "zoom" "p")
)

(defun RDmarker(/ sl1 osmold list1)
  (setvar "cmdecho" 0)
  (setq osmold (getvar "osmode"))
  (setvar "osmode" 0)

  ; Kiểm tra xem block RD Marker có tồn tại chưa
  (if (equal (tblsearch "block" rdmB) nil) (progn
    (command "zoom" "e")
    (command "color" "bylayer")
    (command "line" "0,-1" "0,1" "") ; Vẽ đường thẳng từ (0,-1) đến (0,1)
      (setq list1 (list (cons 0 "LINE") (cons 10 (list 0.0 -1.0 0.0)) (cons 11 (list 0.0 1.0 0.0))))
      (setq sl1 (ssget "l" list1))
      (command "block" rdmB "0,0" sl1 "")
  ))

  (setvar "osmode" osmold)
  (command "zoom" "p")
)
 

[limfx 35]

lisp dài quá!

[cuongtk2 474]

Viết lại một cái gần giống như thế dễ hơn là sửa code đó.

Thấy cách tạo block  Km+ với DText có vẻ sai rồi. Phải dùng Attribute để gán lý trình chứ.

[mourison1993 7]

59 phút trước, cuongtk2 đã nói:

Viết lại một cái gần giống như thế dễ hơn là sửa code đó.

Thấy cách tạo block  Km+ với DText có vẻ sai rồi. Phải dùng Attribute để gán lý trình chứ.

Lisp này cũa nước ngoài bác, e sửa theo ChatGPT lại, thực ra e không biết gì về lisp, chỉ biết chút ít VBA, mà VBA rải theo Polyline khoai quá nên đành bó tay.

[trieubb 9]

Vào lúc 29/7/2025 tại 13:51, mourison1993 đã nói:

Mình có lisp sưu tầm trên mạng và nhờ ChatGPT chỉnh sửa dần cũng được 90% theo ý muốn rồi, còn 1 vấn đề nhỏ là khi rải lý trình trên tuyến thì cọc đầu và cọc cuối không có, mình muốn thêm vào cọc đầu là Km0+000 và cọc cuối sẽ theo chiều dài của đường Polyline, rất mong các bác giúp e chỉnh sửa thêm cho hoàn thiện ạ, e cám ơn!

Nội dung lisp (e không chèn file đính kèm được):

(defun C:RLT()
  (RDInput1)
  (RDSA)
)

(defun C:RDS1()
  (RDSA)
)

(defun RDSA ()
  (setq cmdold (getvar "cmdecho"))
  (setvar "cmdecho" 0)           
  (setq osmold (getvar "osmode"))
  (setvar "osmode" 0)
  (princ) (terpri)

  (setq sst nil)
  (while (= sst nil) 
    (setq sst (entsel "\nChọn tim tuyến:"))
  )

  (setq RD (+ RD rdi)) ; First Value
  (COMMAND "MEASURE" sst "B" rdmB "" mdi)
  (COMMAND "MEASURE" sst "B" "RD" "" rdii)
  (setq SSET (ssget "P")) 

  (setq COUNT 0)
  (while (< COUNT (sslength SSET))
    (setq A1 (ssname SSET count))
    (setq A2 (entget A1))
    (setq A3 (cdr (assoc 0 A2)))
    (if (= A3 "INSERT")
      (progn
        (setq A4 (assoc 10 A2))
        (setq A5 (cdr A4)) 
        (command "EXPLODE" a1)
        (SETQ X1 (ENTGET(ENTLAST)))
        (SETQ X2 (ASSOC 1 X1))
        (SETQ X3 (CDR X2))
        (SETQ RD5 (RTOS RD 2 0))
        (setq RDtxt RD5)
        (text1)
        (setq B1 RDtext)    
        (setq B2 (cons 1 B1))
        (setq A2 (subst B2 X2 X1))
        (entmod A2)
        (SETQ RD5 (ATOF RD5))
        (SETQ RD (+ RD5 rdi))
      )
    )
    (setq count (+ 1 count))
  )
  (setvar "cmdecho" cmdold)
  (setvar "osmode" osmold)
  (terpri)
  (princ (strcat " RD  = " (rtos rd 2 0))) (terpri)
)

(defun text1 (/ abs2 rem1)
  (if (and (= (strlen RDtxt) 1) (= RDtxt "0"))
    (Progn      
      (setq RDtxt "0000")
    )                                               
    (progn                                                                 
      (if (and (> (strlen RDtxt) 1) (<= (strlen RDtxt) 3))           
        (setq RDtxt (strcat "0" RDtxt))
      )                                   
    )                                                                     
  )
  (setq abs2 (substr RDtxt 1 (- (strlen RDtxt) 3)))         
  (setq rem1 (substr RDtxt (+ (strlen abs2) 1)))             
  (setq RDtext (strcat "Km" abs2 "+" rem1))
)

(defun c:RDInput ()
  (RDInput1)
)

(defun c:RD ()
  (RD1)
)

(defun c:RDI()
  (RDI1)
)

(defun c:RDM()
  (RDM1)
)

(defun c:RDMB()
  (RDMB1)
)

(defun c:SF()
  (SF1)
)

(defun RDInput1 ()
  (SF1) ; Scale Factor
  (RD1) ; RD # and block
  (RDblk) 
  (RDI1) ; RD interval
  (RDM1) ; RD marker Interval 
  (RDMB1) ; RD marker block name
)

(defun RD1 (/ RD1)
  (if (= RD nil) (setq RD 0))
  (setq RD1  (getreal (strcat "\nLý trình bắt đầu #  [" (rtos RD 2 0) "] :")))
  (if (/= RD1 nil) (setq RD RD1))
  (princ (strcat "RD = " (rtos rd 2 0))) (terpri)
)

(defun RDI1(/ rdiA)
  (if (= rdi nil) (setq rdi 100))
  (setq rdiA (getreal (strcat "\nNhập khoảng cách điền tên cọc:  [" (rtos RDi 2 0) "] :")))
  (if (/= rdiA nil) (setq rdi rdiA))
  (princ (strcat "RD Intr =  " (rtos rdi 2 0))) (terpri)
  (setq rdii (* rdi ssf))
)

(defun RDM1(/ mdA)
  (if (= md nil) (setq md 100))
  (setq mdA (getreal (strcat "\nNhập khoảng cách rãi cọc:  [" (rtos md 2 0) "] :" )))
  (if (/= mdA nil) (setq md mdA))
  (if (> md rdi) (setq md rdi))
  (princ (strcat "RD marker Dist = " (rtos md 2 0))) (terpri)
  (setq mdi (* md ssf))
)

(defun RDMB1()
  (if (= rdmB nil) (setq rdmB " "))
  (setq rdmB (getstring (strcat "\nĐặt tên block cọc: [" rdmB "]:")))
  (while (equal rdmB "")
    (setq rdmB (getstring (strcat "\nĐặt tên block cọc: [" rdmB "]:")))
  )
  (princ (strcat "RD marker Blk = " rdmB))
  (RDmarker)             ; RD marker Block
)

(defun SF1(/ ssf1)
  (if (= ssf nil) (setq ssf 1.0))
  (setq ssf1 (getreal (strcat "\nNhập tỉ lệ rãi: [" (rtos ssf 2 8) "] :")))
  (if (/= ssf1 nil) (setq ssf ssf1))
  (princ (strcat "Sheet Scale Factor = " (rtos ssf 2 8))) (terpri)
)

(defun RDblk(/ sl curlyr osmold list1 yCoord)
  (setvar "cmdecho" 0)  ; Tắt echo trong command line
  (setq osmold (getvar "osmode"))  ; Lưu trạng thái hiện tại của osmode
  (setvar "osmode" 0)  ; Tắt chế độ chọn đối tượng mặc định

  ; Yêu cầu người dùng nhập chiều cao của block
  (setq height (getreal "\nNhập chiều cao chữ: ")) ; Yêu cầu nhập chiều cao

  ; Yêu cầu người dùng nhập giá trị tọa độ Y cho block
  (setq yCoord (getreal "\nNhập khoảng cách cọc so với tim: [mặc định: -25]:"))
  (if (null yCoord) (setq yCoord -25))  ; Nếu người dùng không nhập gì, mặc định tọa độ là -25

  ; Kiểm tra xem block "RD" đã tồn tại hay chưa
  (if (equal (tblsearch "block" "RD") nil) (progn
    (command "zoom" "e")  ; Phóng to toàn bộ bản vẽ
    (command "style" "ghc" "Arial" "0.0" "1.0" "0" "N" "N")  ; Cài đặt kiểu chữ
    (command "color" "green")  ; Đặt màu sắc cho văn bản
    (command "TEXT" "S" "ghc" "J" "ML" "0,0" height "90" "Km0+000")  ; Vẽ văn bản Km0+000
    (setq list1 (list (cons 0 "TEXT")(cons 1 "Km0+000")))  ; Tạo đối tượng văn bản
    (setq sl (ssget "l" list1))  ; Lấy danh sách đối tượng văn bản
    ; Tạo block "RD" tại tọa độ (0, yCoord)
    (command "block" "RD" (strcat "0," (rtos yCoord 2 0)) sl "")
  ))

  ; Khôi phục trạng thái cũ của osmode
  (setvar "osmode" osmold)
  ; Phóng to lại phạm vi ban đầu
  (command "zoom" "p")
)

(defun RDmarker(/ sl1 osmold list1)
  (setvar "cmdecho" 0)
  (setq osmold (getvar "osmode"))
  (setvar "osmode" 0)

  ; Kiểm tra xem block RD Marker có tồn tại chưa
  (if (equal (tblsearch "block" rdmB) nil) (progn
    (command "zoom" "e")
    (command "color" "bylayer")
    (command "line" "0,-1" "0,1" "") ; Vẽ đường thẳng từ (0,-1) đến (0,1)
      (setq list1 (list (cons 0 "LINE") (cons 10 (list 0.0 -1.0 0.0)) (cons 11 (list 0.0 1.0 0.0))))
      (setq sl1 (ssget "l" list1))
      (command "block" rdmB "0,0" sl1 "")
  ))

  (setvar "osmode" osmold)
  (command "zoom" "p")
)
 

thêm đoạn này:

 

(defun my-angle (p1 p2)
  (atan (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))
)

(defun AddStartEndRDMarker (curveobj ssf yOffset / startpt endpt length RDtxt RDtext ent elist RD5 tangent angle offsetPt)

  ;; ======= CỌC ĐẦU =======
  (setq startpt (vlax-curve-getStartPoint curveobj))
  (setq tangent (vlax-curve-getFirstDeriv curveobj 0.0))
  (if (and tangent startpt)
    (progn
      (setq angle (my-angle '(0.0 0.0) (list (car tangent) (cadr tangent))))
      (setq angle-deg (* angle (/ 180.0 pi)))
      (setq angle (+ angle-deg (/ pi 2))) ; lệch 90 độ
      (command "_.insert" rdmB "R" angle startpt "" "")
      (command "_.insert" "RD" "R" angle startpt "" "")
      (setq RDtxt "0000") ; Lý trình K0+000
      (text1)
      (command "EXPLODE" (entlast))
      (setq ent (entlast))
      (setq elist (entget ent))
      (setq elist (subst (cons 1 RDtext) (assoc 1 elist) elist))
      (entmod elist)
    )
  
  )

  ;; ======= CỌC CUỐI =======
  (setq endpt (vlax-curve-getEndPoint curveobj))
  (setq tangent (vlax-curve-getFirstDeriv curveobj (vlax-curve-getEndParam curveobj)))
  (if (and tangent endpt)
    (progn
      (setq angle (my-angle '(0.0 0.0) (list (car tangent) (cadr tangent))))
      (setq angle-deg (* angle (/ 180.0 pi)))
      (setq angle (+ angle-deg (/ pi 2))) ; lệch 90 độ
      (command "_.insert" rdmB "R" angle endpt "" "")
      (setq length (* (vlax-curve-getDistAtParam curveobj (vlax-curve-getEndParam curveobj)) ssf))
      (setq RD5 (rtos length 2 0)) ; Làm tròn số nguyên
      (setq RDtxt RD5)
      (text1)
      (command "_.insert" "RD" "R" angle endpt "" "")
      (command "EXPLODE" (entlast))
      (setq ent (entlast))
      (setq elist (entget ent))
      (setq elist (subst (cons 1 RDtext) (assoc 1 elist) elist))
      (entmod elist)
    )
  
  )
)

 

và thêm 2 dòng này:

 

(setq curveobj (vlax-ename->vla-object (car sst)))
(AddStartEndRDMarker curveobj ssf yCoord)

 

vào sau đoạn này

 

(while (= sst nil) 
    (setq sst (entsel "\nChọn tim tuyến:"))
  )

[Duong Nhat Duy 484]

Vào lúc 29/7/2025 tại 13:51, mourison1993 đã nói:

Mình có lisp sưu tầm trên mạng và nhờ ChatGPT chỉnh sửa dần cũng được 90% theo ý muốn rồi, còn 1 vấn đề nhỏ là khi rải lý trình trên tuyến thì cọc đầu và cọc cuối không có, mình muốn thêm vào cọc đầu là Km0+000 và cọc cuối sẽ theo chiều dài của đường Polyline, rất mong các bác giúp e chỉnh sửa thêm cho hoàn thiện ạ, e cám ơn!

Bạn tham khảo lisp này của mình nhé, lệnh ME2 để rải cọc tự động, IDT để rải thủ công (trước đó cần ITL, tick ô chèn lý trình, có thể bỏ tick luôn ô block đi cũng được)

 

[mourison1993 7]

7 giờ trước, trieubb đã nói:

thêm đoạn này:

 

(defun my-angle (p1 p2)
  (atan (- (cadr p2) (cadr p1)) (- (car p2) (car p1)))
)

(defun AddStartEndRDMarker (curveobj ssf yOffset / startpt endpt length RDtxt RDtext ent elist RD5 tangent angle offsetPt)

  ;; ======= CỌC ĐẦU =======
  (setq startpt (vlax-curve-getStartPoint curveobj))
  (setq tangent (vlax-curve-getFirstDeriv curveobj 0.0))
  (if (and tangent startpt)
    (progn
      (setq angle (my-angle '(0.0 0.0) (list (car tangent) (cadr tangent))))
      (setq angle-deg (* angle (/ 180.0 pi)))
      (setq angle (+ angle-deg (/ pi 2))) ; lệch 90 độ
      (command "_.insert" rdmB "R" angle startpt "" "")
      (command "_.insert" "RD" "R" angle startpt "" "")
      (setq RDtxt "0000") ; Lý trình K0+000
      (text1)
      (command "EXPLODE" (entlast))
      (setq ent (entlast))
      (setq elist (entget ent))
      (setq elist (subst (cons 1 RDtext) (assoc 1 elist) elist))
      (entmod elist)
    )
  
  )

  ;; ======= CỌC CUỐI =======
  (setq endpt (vlax-curve-getEndPoint curveobj))
  (setq tangent (vlax-curve-getFirstDeriv curveobj (vlax-curve-getEndParam curveobj)))
  (if (and tangent endpt)
    (progn
      (setq angle (my-angle '(0.0 0.0) (list (car tangent) (cadr tangent))))
      (setq angle-deg (* angle (/ 180.0 pi)))
      (setq angle (+ angle-deg (/ pi 2))) ; lệch 90 độ
      (command "_.insert" rdmB "R" angle endpt "" "")
      (setq length (* (vlax-curve-getDistAtParam curveobj (vlax-curve-getEndParam curveobj)) ssf))
      (setq RD5 (rtos length 2 0)) ; Làm tròn số nguyên
      (setq RDtxt RD5)
      (text1)
      (command "_.insert" "RD" "R" angle endpt "" "")
      (command "EXPLODE" (entlast))
      (setq ent (entlast))
      (setq elist (entget ent))
      (setq elist (subst (cons 1 RDtext) (assoc 1 elist) elist))
      (entmod elist)
    )
  
  )
)

 

và thêm 2 dòng này:

 

(setq curveobj (vlax-ename->vla-object (car sst)))
(AddStartEndRDMarker curveobj ssf yCoord)

 

vào sau đoạn này

 

(while (= sst nil) 
    (setq sst (entsel "\nChọn tim tuyến:"))
  )

Em cám ơn bác nhiều lắm! Thành công rồi ạ.

[mourison1993 7]

5 giờ trước, Duong Nhat Duy đã nói:

Bạn tham khảo lisp này của mình nhé, lệnh ME2 để rải cọc tự động, IDT để rải thủ công (trước đó cần ITL, tick ô chèn lý trình, có thể bỏ tick luôn ô block đi cũng được)

 

Em cám ơn bác nhiều ạ! 

[phantuhuong 230]

Bạn nào có mẫu đầu vào trắc dọc tuyến cho tôi xin nhé.

[mourison1993 7]

Vào lúc 4/8/2025 tại 12:38, phantuhuong đã nói:

Bạn nào có mẫu đầu vào trắc dọc tuyến cho tôi xin nhé.

Ý thầy là dữ liệu đầu vào để vẽ trắc dọc tuyến?

[phantuhuong 230]

Bạn nào có xin gửi vào địa chỉ email tuhuongdcct36@gmail.com nhé. Xin cám ơn!