Chuyển đến nội dung
Diễn đàn CADViet
Đăng nhập để thực hiện theo  
nguyenbac_cd

nhờ viết lisp vẽ thêm đường đồng mức phụ

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

chào mọi người !

tình hình là em đang làm đồ án tốt nghiệp đường, phần thiết kế cơ sở với chênh cao đường đồng mức là 5m . khi qua thiết kế kỹ thuật thì yêu cầu đặt ra là phải vẽ thêm các đường đồng mức phụ với bước chênh cao là 1m nằm giữa 2 đường đồng mức có cao độ cho trước,vậy các tiền bối có thể giúp em viết cái lisp vẽ thêm đường đồng mức phụ nằm giữa 2 đường đồng mức có cao độ cho trước  được không ạ,? em cảm ơn 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

Bạn thử cái này, quét 2 đường đồng mức rồi nhập số khoảng chia, ở đây là 5.

 

(defun c:ddm (/ ss sk dd dn lst d1 dis n)
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LWPOLYLINE"))))))
sk (getint "\nSo khoang chia:")
dd (car (vl-sort ss
   '(lambda (x y) (> (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))
     (vlax-curve-getDistAtParam y (vlax-curve-getEndParam y))))))
dn (car (vl-remove dd ss))
dd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget dd)))
lst nil
  )
  (repeat (1- sk) (setq lst (cons '() lst)))
 
  (foreach d0 dd 
    (setq d1 (vlax-curve-getclosestpointto dn d0)
 dis (/ (distance d0 d1) sk)
          n 0)    
    (setq lst (mapcar '(lambda (x) (append x (list (polar d0 (angle d0 d1) (* (setq n (1+ n)) dis))))) lst)) 
  )
  (foreach v lst
    (entmake (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline"))
    (list (cons 90 (length v))) (mapcar '(lambda (x) (cons 10 x)) v  )
    ))
  )
  (princ)      
)
  • 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

 

Bạn thử cái này, quét 2 đường đồng mức rồi nhập số khoảng chia, ở đây là 5.

 

(defun c:ddm (/ ss sk dd dn lst d1 dis n)
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LWPOLYLINE"))))))
sk (getint "\nSo khoang chia:")
dd (car (vl-sort ss
   '(lambda (x y) (> (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))
     (vlax-curve-getDistAtParam y (vlax-curve-getEndParam y))))))
dn (car (vl-remove dd ss))
dd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget dd)))
lst nil
  )
  (repeat (1- sk) (setq lst (cons '() lst)))
 
  (foreach d0 dd 
    (setq d1 (vlax-curve-getclosestpointto dn d0)
 dis (/ (distance d0 d1) sk)
          n 0)    
    (setq lst (mapcar '(lambda (x) (append x (list (polar d0 (angle d0 d1) (* (setq n (1+ n)) dis))))) lst)) 
  )
  (foreach v lst
    (entmake (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline"))
    (list (cons 90 (length v))) (mapcar '(lambda (x) (cons 10 x)) v  )
    ))
  )
  (princ)      
)

chào anh! em cảm ơn anh rất nhiều! em thấy lisp này chỉ nhận được dạng đường PL, chưa được làm trơn, chứ đường đồng mức được làm trơn rồi thì nó không nhận dạng được anh à :(  anh có thể fix lại được không ạ! ?122241_222.png122241_111.png

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ững đường DM của em nó được làm trơn sẵn rồi anh à, những đường như hình số 2 đấy, chứ không phải như đường polyline là những đoạn thẳng nhỏ gãy khúc anh ạ! bật properties lên thấy 2D polyline.

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

Đây bạn, nhưng nó chỉ làm với 2 poly hình dạng gần giống nhau thôi, còn dạng như yên ngựa thì chạy không đúng.

 

(defun c:ddm (/ ss dd dn lst d1 dis n)  
 
  (defun laydinh (en / l)
    (setq l nil)
    (if (= (cdr (assoc 70 (entget en))) 5) (setq tn t) (setq tn nil))
    (while (not (equal (cdr (assoc 0 (entget (setq en (entnext en))))) "SEQEND"))
      (setq l (cons (cdr (assoc 10 (entget en))) l)))
    (if tn (setq l (cons (last l) l)))
    (reverse l)
  )
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POLYLINE")))))))
  (if (not sokhoang) (setq sokhoang (getint "\nSo khoang chia:")))
  (setq dd (car (vl-sort ss '(lambda (x y) (> (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))
     (vlax-curve-getDistAtParam y (vlax-curve-getEndParam y))))))
dn (car (vl-remove dd ss))
dd (laydinh dd)
lst nil
  )
  (repeat (1- sokhoang) (setq lst (cons '() lst)))
 
  (foreach d0 dd 
    (setq d1 (vlax-curve-getclosestpointto dn d0)
 dis (/ (distance d0 d1) sokhoang)
          n 0)    
    (setq lst (mapcar '(lambda (x) (append x (list (polar d0 (angle d0 d1) (* (setq n (1+ n)) dis))))) lst)) 
  )
  (command "undo" "be")
  (foreach v lst
    (entmake '((0 . "POLYLINE") (66 . 1)) )
    (foreach v1 v (entmake (list '(0 . "VERTEX") (cons 10 v1))))
    (entmake '((0 . "SEQEND")))       
  )
  (command "undo" "e") (princ)      
)
  • 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

cảm ơn anh đã nhiệt tình giúp đỡ!

 

Có nút thanks ở dưới bạn viết của thành viên, bạn thấy bài viết hữu ích, hay thì tick vào nhé :)

Thực ra nhiều người k để ý đến phần danh tiếng, n dạo gần đây thấy có chuyện mạo danh, cũng may nhờ mục danh tiếng này mà biết ai thật ai dỏm, ai là người nhiệt tình  :)

  • 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

 

Bạn thử cái này, quét 2 đường đồng mức rồi nhập số khoảng chia, ở đây là 5.

(defun c:ddm (/ ss sk dd dn lst d1 dis n)
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LWPOLYLINE"))))))
sk (getint "\nSo khoang chia:")
dd (car (vl-sort ss
   '(lambda (x y) (> (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))
     (vlax-curve-getDistAtParam y (vlax-curve-getEndParam y))))))
dn (car (vl-remove dd ss))
dd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget dd)))
lst nil
  )
  (repeat (1- sk) (setq lst (cons '() lst)))
 
  (foreach d0 dd 
    (setq d1 (vlax-curve-getclosestpointto dn d0)
 dis (/ (distance d0 d1) sk)
          n 0)    
    (setq lst (mapcar '(lambda (x) (append x (list (polar d0 (angle d0 d1) (* (setq n (1+ n)) dis))))) lst)) 
  )
  (foreach v lst
    (entmake (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline"))
    (list (cons 90 (length v))) (mapcar '(lambda (x) (cons 10 x)) v  )
    ))
  )
  (princ)      
)

anh cho em hỏi tại sao em ap lisp rồi mà không chạy dc ạ

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

cảm ơn anh đã nhiệt tình giúp đỡ!

Hề hề hề,

Gửi bạn cái này để dùng chơi xem sao nhé.

 

(defun c:addm (/ e plst obj ss p0 e1 llst pls i j )
(vl-load-com)
(while (setq e (car (entsel "\n Chon duong dong muc thu nhat")))
   (setq plst (readpl e))
   (setq obj (vlax-ename->vla-object (car (entsel "\n Chon duong dong muc thu hai"))))
   (setq ss (ssadd))
   (command "undo" "be")
   (foreach p plst
        (setq p0 (vlax-curve-getclosestpointto obj p))
        (command "pline" p p0 "")
        (setq e1 (entlast)
                  ss (ssadd e1 ss)   )
   )
   (command "undo" "e")
   (setq llst (acet-ss-to-list ss)
             pls (list) )
   (command "undo" "be")
   (foreach en llst
        (command "divide" en 5)
        (setq ss1 (ssget "p"))
        (setq pts (list)
                 i 0)        
        (repeat 4
              (setq pt (cdr (assoc 10 (entget (ssname ss1 i))))
                        pts (append pts (list pt)) 
                        i (1+ i)  )
        )
        (setq pls (append pls (list pts)))
        (command "erase" ss1 "")
        (setq ss1 nil)
   )
   (command "undo" "e")
   (setq j 0)
   (command "undo" "be")
   (repeat 4
        (if (and (= (cdr (assoc 70 (entget e))) 5) (vlax-curve-isclosed obj))
            (progn
            (command "spline" )
            (foreach lst pls 
                   
                   (command (nth j lst))
            )
            (command "c" "" )
            )
            (progn
            (command "spline" ) 
                     (foreach lst (cdr pls )
                             (setq p (nth j lst))
                             (command p)
                     )
            (command  "" "" "")
            )
         )
         (setq j (1+ j))
    )
    (command "erase" ss"")
    (command "undo" "e")
)
)
 
;;;;;;;
(defun readpl (pl / e l ds p) ;;;; lay danh sach cac dinh cua pline
  (if (not (equal pl etcam))
    (progn
      (setq ds '())
      (setq e (entget pl))
      (setq l (cdr (assoc 0 e)))
      (if (= l "POLYLINE")
(progn
 (setq pl (entnext pl))
 (setq e (entget pl))
 (setq l (cdr (assoc 0 e)))
 (while (= l "VERTEX")
   (setq p (cdr (assoc 10 e)))
   (setq ds (cons p ds))
   (setq pl (entnext pl))
   (setq e (entget pl))
   (setq l (cdr (assoc 0 e)))
 )
)
      )
      (if (= l "LINE")
(setq ds (list
  (cdr (assoc 11 e))
  (cdr (assoc 10 e))
)
)
      )
;(if (/= convangbac 1001) (setq ds nil) )
      (setq ds (reverse ds))
     ;; (if (= l "LWPOLYLINE")
;;(setq ds (xddstdpl pl))
     ;; )
    )
  )
  (setq ds ds)
)

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

 

Hề hề hề,

Gửi bạn cái này để dùng chơi xem sao nhé.

(defun c:addm (/ e plst obj ss p0 e1 llst pls i j )
(vl-load-com)
(while (setq e (car (entsel "\n Chon duong dong muc thu nhat")))
   (setq plst (readpl e))
   (setq obj (vlax-ename->vla-object (car (entsel "\n Chon duong dong muc thu hai"))))
   (setq ss (ssadd))
   (command "undo" "be")
   (foreach p plst
        (setq p0 (vlax-curve-getclosestpointto obj p))
        (command "pline" p p0 "")
        (setq e1 (entlast)
                  ss (ssadd e1 ss)   )
   )
   (command "undo" "e")
   (setq llst (acet-ss-to-list ss)
             pls (list) )
   (command "undo" "be")
   (foreach en llst
        (command "divide" en 5)
        (setq ss1 (ssget "p"))
        (setq pts (list)
                 i 0)        
        (repeat 4
              (setq pt (cdr (assoc 10 (entget (ssname ss1 i))))
                        pts (append pts (list pt)) 
                        i (1+ i)  )
        )
        (setq pls (append pls (list pts)))
        (command "erase" ss1 "")
        (setq ss1 nil)
   )
   (command "undo" "e")
   (setq j 0)
   (command "undo" "be")
   (repeat 4
        (if (and (= (cdr (assoc 70 (entget e))) 5) (vlax-curve-isclosed obj))
            (progn
            (command "spline" )
            (foreach lst pls 
                   
                   (command (nth j lst))
            )
            (command "c" "" )
            )
            (progn
            (command "spline" ) 
                     (foreach lst (cdr pls )
                             (setq p (nth j lst))
                             (command p)
                     )
            (command  "" "" "")
            )
         )
         (setq j (1+ j))
    )
    (command "erase" ss"")
    (command "undo" "e")
)
)
 
;;;;;;;
(defun readpl (pl / e l ds p) ;;;; lay danh sach cac dinh cua pline
  (if (not (equal pl etcam))
    (progn
      (setq ds '())
      (setq e (entget pl))
      (setq l (cdr (assoc 0 e)))
      (if (= l "POLYLINE")
(progn
 (setq pl (entnext pl))
 (setq e (entget pl))
 (setq l (cdr (assoc 0 e)))
 (while (= l "VERTEX")
   (setq p (cdr (assoc 10 e)))
   (setq ds (cons p ds))
   (setq pl (entnext pl))
   (setq e (entget pl))
   (setq l (cdr (assoc 0 e)))
 )
)
      )
      (if (= l "LINE")
(setq ds (list
  (cdr (assoc 11 e))
  (cdr (assoc 10 e))
)
)
      )
;(if (/= convangbac 1001) (setq ds nil) )
      (setq ds (reverse ds))
     ;; (if (= l "LWPOLYLINE")
;;(setq ds (xddstdpl pl))
     ;; )
    )
  )
  (setq ds ds)
)

sao e ko chạy đc lisp 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

nếu muốn đường đồng mức thì bạn nghiên cứu món Land Desktop hoặc Civil 3D ý, rất nhanh và chính xác :D

a ơi!chỉ có chạy đường đồng mức mà cài land(gần 2g hay bị lỗi) và civil3d(gần 3g) có đáng không?giờ phải nhờ được bác nào có cái lisp vẽ đồng mức từ point hay gì đó thì nhẹ nhàng hơn

  • 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

 

Đây bạn, nhưng nó chỉ làm với 2 poly hình dạng gần giống nhau thôi, còn dạng như yên ngựa thì chạy không đúng.

(defun c:ddm (/ ss dd dn lst d1 dis n)  
 
  (defun laydinh (en / l)
    (setq l nil)
    (if (= (cdr (assoc 70 (entget en))) 5) (setq tn t) (setq tn nil))
    (while (not (equal (cdr (assoc 0 (entget (setq en (entnext en))))) "SEQEND"))
      (setq l (cons (cdr (assoc 10 (entget en))) l)))
    (if tn (setq l (cons (last l) l)))
    (reverse l)
  )
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "POLYLINE")))))))
  (if (not sokhoang) (setq sokhoang (getint "\nSo khoang chia:")))
  (setq dd (car (vl-sort ss '(lambda (x y) (> (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))
     (vlax-curve-getDistAtParam y (vlax-curve-getEndParam y))))))
dn (car (vl-remove dd ss))
dd (laydinh dd)
lst nil
  )
  (repeat (1- sokhoang) (setq lst (cons '() lst)))
 
  (foreach d0 dd 
    (setq d1 (vlax-curve-getclosestpointto dn d0)
 dis (/ (distance d0 d1) sokhoang)
          n 0)    
    (setq lst (mapcar '(lambda (x) (append x (list (polar d0 (angle d0 d1) (* (setq n (1+ n)) dis))))) lst)) 
  )
  (command "undo" "be")
  (foreach v lst
    (entmake '((0 . "POLYLINE") (66 . 1)) )
    (foreach v1 v (entmake (list '(0 . "VERTEX") (cons 10 v1))))
    (entmake '((0 . "SEQEND")))       
  )
  (command "undo" "e") (princ)      
)

Sao em ap rồi mà lip ko chạy được nữa vậ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

 

Bạn thử cái này, quét 2 đường đồng mức rồi nhập số khoảng chia, ở đây là 5.

(defun c:ddm (/ ss sk dd dn lst d1 dis n)
  
  (setq ss (vl-remove-if 'listp (mapcar 'cadr (ssnamex (ssget '((0 . "LWPOLYLINE"))))))
sk (getint "\nSo khoang chia:")
dd (car (vl-sort ss
   '(lambda (x y) (> (vlax-curve-getDistAtParam x (vlax-curve-getEndParam x))
     (vlax-curve-getDistAtParam y (vlax-curve-getEndParam y))))))
dn (car (vl-remove dd ss))
dd (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget dd)))
lst nil
  )
  (repeat (1- sk) (setq lst (cons '() lst)))
 
  (foreach d0 dd 
    (setq d1 (vlax-curve-getclosestpointto dn d0)
 dis (/ (distance d0 d1) sk)
          n 0)    
    (setq lst (mapcar '(lambda (x) (append x (list (polar d0 (angle d0 d1) (* (setq n (1+ n)) dis))))) lst)) 
  )
  (foreach v lst
    (entmake (append '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline"))
    (list (cons 90 (length v))) (mapcar '(lambda (x) (cons 10 x)) v  )
    ))
  )
  (princ)      
)

Lisp anh tải lên em load rồi nhưng vẫn không sử dụng được. Anh có thể xem lại và cho em xin với được không ak. Lisp này rất là hay. Mong các Cadman sư huynh chỉ giáo.

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

Đăng nhập để thực hiện theo  

×