注册 登录
明经CAD社区 返回首页

yxh1202的个人空间 http://www.mjtd.com/?364298 [收藏] [复制] [分享] [RSS]

留言板

facelist doodle涂鸦板

您需要登录后才可以留言 登录 | 注册


f4800 2020-11-3 11:02
你好  提取横断面图中横地线的程序 处理好了么? 方便分享下么
Atsai 2019-12-9 17:42
yxh1202: 您也是做水工设计的吧。
请问你的横断面土方工具怎么样了
可以到下面的连结看一下,应该有你想要的!
Hatching islands between two polylines,可以求出二条Pline的挖填方。
https://www.theswamp.org/index.php?topic=45305.15

https://www.theswamp.org/index.php?action=dlattach;topic=45305.0;attach=32257

这个不考虑结构物,只考虑二条Pline,希望对你有帮助。
若是连不出去,直接抓下面的源码吧!


;;; Cut & Fill      by ymg                                                    ;
;;;                                                                           ;



(defun c:cf (/ ** *acdoc* a are b bnd c cutcol d dir dl1 dl2 e fillcol hcol
               intl len1 len2 p p0 p1 p2 pm pol1 pol2 sp1 sp2 spe ss1
               ss2 totcut totfill txt txtlayer varl)
               
   (vl-load-com)

   (defun *error* (msg)
        (mapcar 'eval varl)
        (if (and msg (not (wcmatch (strcase msg) "*BREAK*,*CANCEL*,*EXIT*")))
           (princ (strcat "\nError: " msg))
        )
        (and *acdoc* (vla-endundomark *acdoc*))
        (princ)
   )

   (setq varl '("OSMODE" "CMDECHO" "DIMZIN" "PEDITACCEPT")
         varl (mapcar (function (lambda (a) (list 'setvar a (getvar a)))) varl)
   )

   (or *acdoc* (setq *acdoc* (vla-get-activedocument (vlax-get-acad-object))))

   (vla-startundomark *acdoc*)

   (setvar 'CMDECHO 0)
   (setvar 'DIMZIN  0)
   (setvar 'OSMODE  0)


   (setq cutcol 1  fillcol 3  ; Cut is Red, Fill is Green                     ;
         totcut 0  totfill 0  ; Total Cut and Total Fill                      ;
           txtlayer "Text"    ; Name of Layer for Cut and Fill Values         ;

   )
   (while (not (setq **  (princ "\nSelect Reference Polyline:")
                     ss1 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
               )
          )
        (princ "\nYou Must Select a Polyline:")
   )                  
   (while (not (setq **  (princ "\nSelect Proposed Polyline:")
                     ss2 (ssget "_+.:L:S" '((0 . "LWPOLYLINE")))
               )
          )
        (princ "\nYou Must Select a Polyline:")
   )

     
   (setq pol1 (ssname ss1 0)
         len1 (vlax-curve-getDistAtParam pol1 (vlax-curve-getEndParam pol1))
         pol2 (ssname ss2 0)
         len2 (vlax-curve-getDistAtParam pol2 (vlax-curve-getEndParam pol2))
         sp1  (vlax-curve-getstartpoint pol1)
         spe  (vlax-curve-getendpoint pol1)
         sp2  (if (vlax-curve-isClosed pol2)
                 (setq lst2 (listpol pol2)
                       disl (mapcar '(lambda (a) (distance sp1 a)) lst2)
                       **   (plineorg pol2 (nth (vl-position (apply 'min disl) disl) lst2))
                 )
                 (vlax-curve-getstartpoint pol2)
               )  
         dir  (if (< (/ pi 2) (angle sp1 spe) (/ (* 3 pi) 2)) -1 1)
   )      
   

   ; Getting all the intersections between poly.                              ;

   (setq intl (intersections pol1 pol2))

   (if (> (length intl) 1)
      (progn
   
   ; Computing distance of intersections on each polyline                     ;
   
         (setq dl1  (mapcar '(lambda (a) (getdistoncurve pol1 a)) intl)
               dl2  (mapcar '(lambda (a) (getdistoncurve pol2 a)) intl)
         )
   
   ; If both polyline are closed add first Intersection to end of list        ;
   ; We also add a distance to each distances list                            ;

         (if (and (vlax-curve-isClosed pol1) (vlax-curve-isClosed pol2))
            (setq dl1  (append dl1 (list (+ (car dl1) len1)))
                  dl2  (append dl2 (list (+ (car dl2) len2)))
                  intl (append intl (list (car intl)))
                  dir  (if (iscw_p (listpol pol1)) -1 1)   
            )      
         )
   

   ; Finding points at mid-distance between intersections on each polyline    ;
   ; Calculating midpoint between mid-distance points to get an internal point;
   ; Creating a list of all these points plus the intersection points         ;
   
         (setq pm
            (mapcar
                '(lambda (a b c d e)
                    (list (midpoint
                              (setq p1 (getptoncurve pol1 (rem (* (+ a b) 0.5) len1)))
                              (setq p2 (getptoncurve pol2 (rem (* (+ c d) 0.5) len2)))
                           )
                           p1 p2 e            
                     )
                  )
                  dl1 (cdr dl1) dl2 (cdr dl2) intl
             )
         )      

   
   
         (foreach i pm
            (setq  p (car    i)  ; Midpoint between p1 p2                           ;
                  p0 (cadddr i)  ; Intersection Point                               ;
                  p1 (cadr   i)  ; Midpoint of Intersections on Reference Polyline  ;
                  p2 (caddr  i)  ; Midpoint of Intersections on Proposed Polyline   ;
            )
            (if (> (abs (onside p2 p0 p1)) 1e-3) ; Not Colinear                     ;
               (progn
                  (vl-cmdf "._-BOUNDARY" p "")
                  (setq are (vla-get-area (vlax-ename->vla-object (entlast)))
                        bnd (entlast)
                  )
            
                  (if (minusp (* (onside p2 p0 p1) dir))               
                     (setq totfill (+ totfill are) hcol fillcol)
                     (setq totcut  (+ totcut  are) hcol  cutcol)
                  )
               
                  (vl-cmdf "._-HATCH" "_CO" hcol "." "_P" "SOLID" "_S" bnd "" "")
                  (entdel bnd)
               )
            )
         )
         (setq   p (cadr (grread nil 13 0))
               txt (strcat "{\\C3;Fill: " (rtos totfill 2 2) " m2\\P\\C1;Cut: " (rtos totcut  2 2) " m2}")
         )        
         (entmakex (list
                      (cons 0 "MTEXT")
                      (cons 100 "AcDbEntity")
                      (cons 8 txtlayer)
                      (cons 100 "AcDbMText")
                      (cons 10 p)               
                      (cons 40 3.0)
                      (cons 1 txt)
                    )
         )           

         (command "_MOVE" (entlast) "" p pause)
      )
      (Alert "Not Enough Intersections To Process !")
  )

  (*error* nil)

)

(princ "\nCalculates Cut & Fill Between Two Intersecting Polylines")
(princ "\nCF to start...")



(defun midpoint (p1 p2)
   (mapcar '(lambda (a b) (* (+ a b) 0.5)) p1 p2)
)

; onside        by ymg                                                        ;
; Negative return, point is on left of v1->v2                                 ;
; Positive return, point is on right of v1->v2                                ;
;        0 return, point is smack on the vector.                              ;
;                                                                             ;

(defun onside (p v1 v2 / x y)
    (setq x (car p) y (cadr p))
    (- (* (- (cadr v1) y) (-  (car v2) x)) (* (- (car  v1) x) (- (cadr v2) y)))
)

;                                                                             ;
; Is Polyline Clockwise                      by LeeMac                        ;
;                                                                             ;
; Argument:   l,  Point List                                                  ;
; Returns:    t, Polyline is ClockWise                                        ;
;           nil, Polyline is CounterClockWise                                 ;
;                                                                             ;

(defun iscw_p (l)
    (if (equal (car l) (last l) 1e-8) (setq l (cdr l)))
    (minusp
        (apply '+
            (mapcar
                (function
                  (lambda (a b) (- (* (car b) (cadr a)) (* (car a) (cadr b))))
                )
                l (cons (last l) l)
            )
        )
    )
)

;;                                                                            ;
;; Return list of intersection(s) between two VLA-Object or two ENAME         ;
;; obj1 - first VLA-Object                                                    ;
;; obj2 - second VLA-Object                                                   ;
;; mode - intersection mode (acExtendNone acExtendThisEntity                  ;
;;                                acExtendOtherEntity acExtendBoth)           ;
;; Requires triplet                                                           ;
;;                                                                            ;

(defun Intersections (obj1 obj2)
   (or (= (type obj1) 'VLA-OBJECT) (setq obj1 (vlax-ename->vla-object obj1)))
   (or (= (type obj2) 'VLA-OBJECT) (setq obj2 (vlax-ename->vla-object obj2)))
           
   (triplet (vlax-invoke obj1 'intersectwith obj2 acExtendNone))
)

;;                                                                            ;
;; triplet, Separates a list into triplets of items.                          ;
;;                                                                            ;

(defun triplet (l)
   (if l (cons (list (car l) (cadr l) (caddr l))(triplet (cdddr l))))
)


(defun getdistoncurve (e p)
   (vlax-curve-getDistatParam e
        (vlax-curve-getparamatpoint e
             (vlax-curve-getclosestpointto e p)
        )     
   )         
)

(defun getptoncurve (e d)
   (vlax-curve-getpointatparam e (vlax-curve-getparamatdist e d))
)

;;                                                                            ;
;; listpol     by ymg    (Simplified a Routine by Gile Chanteau               ;
;;                                                                            ;
;; Parameter:  en,  Entity Name or Object Name of Any Type of Polyline        ;
;;                                                                            ;
;; Returns:    List of Points in Current UCS                                  ;
;;                                                                            ;
;; Notes:      On Closed Polyline the Last Vertex is Same as First)           ;
;;                                                                            ;

(defun listpol (en / i l)
   (repeat (setq i (fix (1+ (vlax-curve-getEndParam en))))
      (setq l (cons (trans (vlax-curve-getPointAtParam en (setq i (1- i))) 0 1) l))
   )
)


;; plineorg   by (gile) (Modified into a function by ymg)                     ;
;;  https://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/          ;
;;            change-polyline-start-point/td-p/2154331                        ;
;;                                                                            ;
;; Function to modify origin of a closed polyline                             ;
;;                                                                            ;
;; Arguments:                                                                 ;
;;   en : Ename or VLA-Object of a Closed Polyline.                           ;
;;   pt : Point                                                               ;
;;                                                                            ;
;; Returns: Point of Origin if successful, else nil.                          ;
;;                                                                            ;

(defun plineorg (en pt / blst d1 d2 d3 n norm obj pa plst)
   (if (= (type en) 'ENAME)
      (setq obj (vlax-ename->vla-object  en))
      (setq obj en   en (vlax-vla-object->ename obj))
   )
   
    ;; bulgratio   by (gile)                                 ;
    ;; Returns a bulge which is proportional to a reference  ;
    ;; Arguments :                                           ;
    ;; b : the reference bulge                               ;
    ;; k : the ratio (between angles or arcs length)         ;

   (defun bulgratio (b k / a)
      (setq a (atan b))
      (/ (sin (* k a)) (cos (* k a)))
   )

    ;; Sublist  by (gile)                                    ;
    ;; Returns a sublist similar to substr function.         ;
    ;; lst : List from which sublist is to be extracted      ;
    ;; idx : Index of Item at Start of sublist               ;
    ;; len : Length of sublist or nil to return all items.   ;

   (defun sublist (lst n len / rtn)
      (if (or (not len) (< (- (length lst) n) len))
         (setq len (- (length lst) n))
      )
      (setq n (+ n len))
      (repeat len
         (setq rtn (cons (nth (setq n (1- n)) lst) rtn))
      )
   )

   (if (and (= (vla-get-closed obj) :vlax-true)
            (= (vla-get-objectname obj) "AcDbPolyline")
       )     
      (progn
         (setq plst (vlax-get obj 'coordinates)
               norm (vlax-get obj 'normal)
               pt   (vlax-curve-getClosestPointTo en (trans pt 1 0))
               pa   (vlax-curve-getparamatpoint obj pt)
               n    (/ (length plst) 2)         
         )
         (repeat n
            (setq blst (cons (vla-getbulge obj (setq n (1- n))) blst))
         )
         (if (= pa (fix pa))
            (setq n    (fix pa)
                  plst (append (sublist plst (* 2 n) nil)
                               (sublist plst 0 (* 2 n))
                       )
                  blst (append (sublist blst n nil) (sublist blst 0 n))
            )
            (setq n    (1+ (fix pa))
                  d3   (vlax-curve-getdistatparam en n)
                  d2   (- d3 (vlax-curve-getdistatpoint en pt))
                  d3   (- d3 (vlax-curve-getdistatparam en (1- n)))
                  d1   (- d3 d2)
                  pt   (trans pt 0 (vlax-get obj 'normal))
                  plst (append (list (car pt) (cadr pt))
                               (sublist plst (* 2 n) nil)
                               (sublist plst 0 (* 2 n))
                       )
                  blst (append (list (bulgratio (nth (1- n) blst) (/ d2 d3)))
                               (sublist blst n nil)
                               (sublist blst 0 (1- n))
                               (list (bulgratio (nth (1- n) blst) (/ d1 d3)))
                       )
            )
         )
         (vlax-put obj 'coordinates plst)
         (repeat (setq n (length blst))
            (vla-setbulge obj (setq n (1- n)) (nth n blst))
         )
         (trans pt 0 1)
      )
      nil
   )
)
zhouman 2012-6-4 12:18
你好 你有lisp自动绘制生成纵横断面的程序吗

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码,在未取得本站及作者授权的情况下,不得用于商业用途

GMT+8, 2024-3-29 14:13 , Processed in 0.096175 second(s), 9 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

返回顶部