Đến nội dung


Hình ảnh
- - - - -

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


  • Please log in to reply
17 replies to this topic

#1 nguyenbac_cd

nguyenbac_cd

    biết vẽ line

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

Đã gửi 01 November 2014 - 12:49 AM

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!

 


  • 0

#2 hochoaivandot

hochoaivandot

    biết dimradius

  • Members
  • PipPipPipPipPip
  • 310 Bài viết
Điểm đánh giá: 107 (tàm tạm)

Đã gửi 01 November 2014 - 10:06 AM

Dùng Nova thì dùng tiếp Nova đi. Tại sao lại đổi sang dùng lisp


  • 0

Dương Bá Diệp

 

www.cadonline.duyxuyen.vn 

 

Thành viên nhóm CADMAGIC

 


#3 nguyenbac_cd

nguyenbac_cd

    biết vẽ line

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

Đã gửi 01 November 2014 - 11:57 AM

em đang dùng VNROAD bản education nên bị hạn chế tính năng này , nova hay lỗi quá nên e k có dùng :)


  • 0

#4 Tot77

Tot77

    biết lệnh adcenter

  • Members
  • PipPipPipPipPipPipPip
  • 990 Bài viết
Điểm đánh giá: 498 (tốt)

Đã gửi 02 November 2014 - 11:12 AM

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)      
)

  • 2

#5 nguyenbac_cd

nguyenbac_cd

    biết vẽ line

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

Đã gửi 02 November 2014 - 05:14 PM

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


  • 0

#6 Tot77

Tot77

    biết lệnh adcenter

  • Members
  • PipPipPipPipPipPipPip
  • 990 Bài viết
Điểm đánh giá: 498 (tốt)

Đã gửi 02 November 2014 - 05:27 PM

Làm trơn là sao bạn?
  • 1

#7 nguyenbac_cd

nguyenbac_cd

    biết vẽ line

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

Đã gửi 02 November 2014 - 05:31 PM

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.


  • 0

#8 nguyenbac_cd

nguyenbac_cd

    biết vẽ line

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

Đã gửi 02 November 2014 - 05:39 PM

em gửi bình đồ lên, anh xem giùm em luôn nhé!

anh xem dạng đường DM trong bình đồ của em.http://www.cadviet.c...122241_send.dwg


  • 0

#9 Tot77

Tot77

    biết lệnh adcenter

  • Members
  • PipPipPipPipPipPipPip
  • 990 Bài viết
Điểm đánh giá: 498 (tốt)

Đã gửi 02 November 2014 - 07:33 PM

Đâ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)      
)

  • 1

#10 nguyenbac_cd

nguyenbac_cd

    biết vẽ line

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

Đã gửi 02 November 2014 - 11:05 PM

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


  • 0

#11 ketxu

ketxu

    Copier - Paster - Editor

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

Đã gửi 03 November 2014 - 08:47 AM

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  :)


  • 1

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


#12 vu dinh loc

vu dinh loc

    Chưa sử dụng CAD

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

Đã gửi 01 June 2015 - 08:36 AM

 

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 ạ


  • 0

#13 phamthanhbinh

phamthanhbinh

    biết lệnh adcenter

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

Đã gửi 02 June 2015 - 10:51 AM

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)
)

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

#14 LÉYHIEP

LÉYHIEP

    Chưa sử dụng CAD

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

Đã gửi 26 January 2016 - 11:30 AM

sao e chạy lisp rồi mà nhập lệnh ko đc nhỉ ?


  • 0

#15 LÉYHIEP

LÉYHIEP

    Chưa sử dụng CAD

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

Đã gửi 26 January 2016 - 05:56 PM

 

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ỉ


  • 0

#16 hihi.hehe

hihi.hehe

    biết zoom

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

Đã gửi 26 January 2016 - 08:27 PM

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


  • 0

#17 bda50

bda50

    Edu level: ao10, to7

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

Đã gửi 17 February 2016 - 02:57 PM

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


  • 0

#18 hungtrangt

hungtrangt

    Chưa sử dụng CAD

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

Đã gửi 20 October 2016 - 01:45 PM

 

Đâ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 ạ


  • 0