断面线点表生成断面挖填点表

13648893846 · 发表于 2018-9-12 22:40:54

;;[功能]断面数据点表生成断面挖填点表
;;[用法](LC:Section-line-ptlst-sort-lst ptlst1 ptlst2)
;;[作者]BY 老仓测绘上班记
;;;(setq ptlst1 (LC:WH-vxs (car (entsel"\n 请选择原始地貌线："))))
;;;(setq ptlst2 (LC:WH-vxs (car (entsel"\n 请选择设计j线："))))
;;;(PTLST1 PTLST2 / INTPTS ORIGINAL-INT DESIGN-INT I II ORIGINAL-INT-NEW JBLST WFLST TFLST INTPT DESIGN-INT1 ORIGINAL-INT1)
(defun LC:Section-line-ptlst-sort-lst (PTLST1 PTLST2 /)
 (setq intpts (BF-list-delsame (LC:TWO-ptlst-inters-lst ptlst1 ptlst2 "0")0.001));交点表
 (setq Original-int '() design-int '())
 (setq Original-int (append Original-int ptlst1 intpts);原始地貌线总数据
design-int (append design-int ptlst2 intpts));设计线总数据
 ;交点及原始断面数据按Y值从小到大即断面图从左到右排序（Y值控制偏距）
 (setq design-int (BF-list-delsame(vl-sort design-int '(lambda (x y) (> (car x) (car y))))0.001))
 (setq Original-int (BF-list-delsame(vl-sort Original-int '(lambda (x y) (< (car x) (car y))))0.001))
 (setq i 0 ii 0 Original-int-new '() wtfllst '() wflst '() tflst '())
 (repeat (- (length intpts) 1)
(progn
 (setq intpt1 (nth ii intpts));第ii个交点
 (setq intpt2 (nth (+ ii 1) intpts));第ii个交点
 (setq Original-int1 (vl-remove-if '(lambda (x) (or (<= (car x) (car(nth ii intpts))) (>= (car x) (car(nth (1+ ii) intpts))))) Original-int));原始断面线两交点之间的端点列表
 (setq design-int1 (vl-remove-if '(lambda (x) (or (<= (car x) (car(nth ii intpts))) (>= (car x) (car(nth (1+ ii) intpts))))) design-int));设计线两交点之间的端点列表
;;; (setq jblst (append jblst (list (append (list intpt1) Original-int1 (list intpt2) design-int1))));把每段地面线数据及设计数据合并(append design-int1 design-int1 Original-int1)
 (if (and (last design-int1) (or (> (cadr(nth ii intpts)) (cadr(last design-int1))) (> (cadr(nth (1+ ii) intpts)) (cadr(last design-int1)))))
(setq wflst (append wflst (list (append (list intpt1) Original-int1 (list intpt2) design-int1))))
(setq tflst (append tflst (list (append (list intpt1) Original-int1 (list intpt2) design-int1))))
 )
)
(setq ii (1+ ii))
 )
 (setq wtfllst (append wtfllst (list wflst) (list tflst)));挖填总表
 (princ wtfllst)
 (princ)
)

Atsai · 发表于 2018-9-15 21:05:24

有兴趣的可以移驾到下面的连结去看一下：
https://www.theswamp.org/index.php?topic=45305.15

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

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

13648893846 · 发表于 2018-11-13 17:58:14

;;[功能]两点表计算交点
;;[用法](LC:TWO-ptlst-inters-lst ptlst1 ptlst2 "0")
;;[作者]BY 老仓测绘上班记
;;说明:得到两个二维点表的交点
;;用非vla-IntersectWith方法不生成对象写的点表交点函数，可选多种延长方向，两点表都可以选择是否双向延长还是各自单向延长
;;参数:lst1:点表1
;;参数:lst2:点表2
;;参数:typ:延长类型（不区别大小写）："0000"或其他—两个都不延长;"0001"—延长点表2右侧两个点; "0010"—延长点表2左侧两个点； "0011"—延长点表2两侧两个点; "1000"—延长点表1左侧两个点; "0100"—延长点表1右侧两个点；"1100"—延长点表1两侧两个点;"1111"—延长点表1和点表2两侧两个点;
;;返回:符合条件的包括所有交点的二维点表
;;示例
;;;(setq ptlst1 (LC:WH-vxs (car (entsel"\n 请选择原始地貌线："))))
;;;(setq ptlst2 (LC:WH-vxs (car (entsel"\n 请选择设计j线："))))
 ;(setq lst1 (list (list 1492.5310 356.4799) (list 1693.9629 457.0300) (list 2085.9058 466.7216) (list 2281.2705 367.3829)))
 ;(setq lst2 (list (list 1567.8204 362.9696) (list 1667.2671 324.9823) (list 1980.3360 258.3527) (list 2205.2348 357.8477)))
 ;(setq typ "0011")
 ;(LC:TWO-ptlst-inters-lst lst1 lst2 typ)
 ;((1532.53 376.449) (2255.92 380.272))
(defun LC:TWO-ptlst-inters-lst (lst1 lst2 typ / ii jj pt1 pt2 pt3 pt4 azi intpt interpt)
(setq ii (length lst1))
(setq jj (length lst2))
 ;延长lst1左侧
 (if (= (substr typ 1 1) "1")
(progn
 (setq pt1 (nth 0 lst1))
 (setq pt2 (nth 1 lst1))
 (setq azi (angle pt1 pt2))
 (setq azi (+ pi azi))
 (setq lst1 (append (list (polar pt1 azi 10000) ) lst1 ))
)
 )
 ;延长lst1右侧
 (if (= (substr typ 2 1) "1")
(progn
 (setq pt1 (nth (1- ii) lst1))
 (setq pt2 (nth ii lst1))
 (setq azi (angle pt1 pt2))
 (setq lst1 (append lst1 (list (polar pt2 azi 10000) ) ))
)
 )
 ;延长lst2左侧
 (if (= (substr typ 3 1) "1")
(progn
 (setq pt3 (nth 0 lst2))
 (setq pt4 (nth 1 lst2))
 (setq azi (angle pt3 pt4))
 (setq azi (+ pi azi))
 (setq lst2 (append (list (polar pt3 azi 10000) ) lst2 ))
)
 )
 ;延长lst2右侧
 (if (= (substr typ 4 1) "1")
(progn
 (setq pt3 (nth (1- jj) lst2))
 (setq pt4 (nth jj lst2))
 (setq azi (angle pt3 pt4))
 (setq lst2 (append lst2 (list (polar pt4 azi 10000) ) ))
)
 )
 ;计算交点坐标
(setq ii (1- (length lst1)))
(setq jj (1- (length lst2)))
(setq intpt nil interpt nil i 0 )
(while (< i ii)
 (setq pt1 (nth i lst1))
 (setq pt2 (nth (1+ i) lst1))
 (setq j 0)
 (while (< j jj)
 (setq pt3 (nth j lst2))
 (setq pt4 (nth (1+ j) lst2))
 (setq intpt (inters pt1 pt2 pt3 pt4 t) )
 (if (/= intpt nil)
 ;将交点坐标存入点表
 (setq interpt (append interpt (list intpt)))
 )
 (setq j (1+ j))
 )
 (setq i (1+ i))
)
interpt
)

;;;name:BF-list-delsame
;;;desc:删除表中相同元素，保留第一次出现的位置
;;;arg:lst:列表
;;;arg:buzz:容差
;;;return:删除重复元素组成的表
;;;example

BF-list-delsame '(0 1 2 3 2 4 4) 0.1)---->(0 1 2 3 4)
(defun BF-list-delsame (lst buzz)
  (if Lst
(cons (car Lst)
   (BF-list-delsame
      (vl-remove-if
      '(lambda (x) (equal (car lst) x buzz))
      (cdr lst)
      )
      buzz
   )
)
  )
)

yanshengjiang · 发表于 2018-11-12 14:05:18

13648893846 发表于 2018-9-21 11:19
工作之余逐步写函数完善CASS任意断面法功能，太菜可能要很长一段时间

南方cass生成里程文件的时候，是按距离采样。不能按实际地形点采样。目前我已经写了一个根据图面实际高程点采样的插件

ynhh · 发表于 2018-9-13 08:31:18

老仓老师最好是来个实例

好学习

xyp1964 · 发表于 2018-9-13 21:03:58

cnks · 发表于 2018-9-14 12:53:30

本帖最后由 cnks 于 2018-9-14 12:57 编辑

xyp1964 发表于 2018-9-13 21:03

这个功能厉害，自动出工程量

hao3ren · 发表于 2018-9-14 13:36:11

函数不全，无法应用

13648893846 · 发表于 2018-9-15 19:16:27

欠缺的函数论坛都有

hao3ren · 发表于 2018-9-15 21:53:41

13648893846 发表于 2018-9-15 19:16
欠缺的函数论坛都有

搜过了，没找到

fanqinwei · 发表于 2018-9-19 16:34:34

可以把老仓老师的这几个做成一个断面版块工具了

13648893846 · 发表于 2018-9-21 11:19:16

工作之余逐步写函数完善CASS任意断面法功能，太菜可能要很长一段时间

账号		自动登录	找回密码
密码			注册

[函数] 断面线点表生成断面挖填点表

本帖子中包含更多资源