明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 2239|回复: 9

填方路基横断面自动分层?

[复制链接]
发表于 2019-12-25 19:00:10 | 显示全部楼层 |阅读模式
本帖最后由 树櫴希德 于 2019-12-25 21:09 编辑

  1. (defun LM:outline (sel      /       LM:ssboundingbox  app
  2.        are      box       cmd      dis      enl
  3.        ent      lst       obj      rtn      tmp
  4.       )
  5.   (defun LM:ssboundingbox (s / a b i m n o)
  6.     (repeat (setq i (sslength s))
  7.       (if
  8.   (and
  9.     (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
  10.     (vlax-method-applicable-p o 'getboundingbox)
  11.     (not
  12.       (vl-catch-all-error-p
  13.         (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))
  14.       )
  15.     )
  16.   )
  17.    (setq m (cons (vlax-safearray->list a) m)
  18.          n (cons (vlax-safearray->list b) n)
  19.    )
  20.       )
  21.     )
  22.     (if  (and m n)
  23.       (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
  24.         '(min max)
  25.         (list m n)
  26.       )
  27.     )
  28.   )
  29.   (if (setq box (LM:ssboundingbox sel))
  30.     (progn
  31.       (setq app  (vlax-get-acad-object)
  32.       dis  (/ (apply 'distance box) 20.0)
  33.       lst  (mapcar  '(lambda (a o) (mapcar o a (list dis dis)))
  34.       box
  35.       '(- +)
  36.     )
  37.       are  (apply '* (apply 'mapcar (cons '- (reverse lst))))
  38.       dis  (* dis 1.5)
  39.       ent
  40.     (entmakex
  41.       (append
  42.         '((000 . "LWPOLYLINE")
  43.           (100 . "AcDbEntity")
  44.           (100 . "AcDbPolyline")
  45.           (090 . 4)
  46.           (070 . 1)
  47.          )
  48.         (mapcar '(lambda (x)
  49.              (cons 10 (mapcar '(lambda (y) ((eval y) lst)) x))
  50.            )
  51.           '((caar cadar)
  52.             (caadr cadar)
  53.             (caadr cadadr)
  54.             (caar cadadr)
  55.            )
  56.         )
  57.       )
  58.     )
  59.       )
  60.       (apply
  61.   'vlax-invoke
  62.   (vl-list* app
  63.       'zoomwindow
  64.       (mapcar '(lambda (a o) (mapcar o a (list dis dis 0.0)))
  65.         box
  66.         '(- +)
  67.       )
  68.   )
  69.       )
  70.       (setq cmd  (getvar 'cmdecho)
  71.       enl  (entlast)
  72.       rtn  (ssadd)
  73.       )
  74.       (while (setq tmp (entnext enl)) (setq enl tmp))
  75.       (setvar 'cmdecho 0)
  76.       (command
  77.   "_.-boundary"
  78.   "_a"
  79.   "_b"
  80.   "_n"
  81.   sel
  82.   ent
  83.   ""
  84.   "_i"
  85.   "_y"
  86.   "_o"
  87.   "_p"
  88.   ""
  89.   (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0)))
  90.          0
  91.          1
  92.   )
  93.   ""
  94.       )
  95.       (while (< 0 (getvar 'cmdactive)) (command ""))
  96.       (entdel ent)
  97.       (while (setq enl (entnext enl))
  98.   (if (and (vlax-property-available-p
  99.        (setq obj (vlax-ename->vla-object enl))
  100.        'area
  101.      )
  102.      (equal (vla-get-area obj) are 1e-4)
  103.       )
  104.     (entdel enl)
  105.     (ssadd enl rtn)
  106.   )
  107.       )
  108.       (vla-zoomprevious app)
  109.       (setvar 'cmdecho cmd)
  110.       rtn
  111.     )
  112.   )
  113. )

  114. ;(LM:outline(ssget))

  115. (defun PoInPl(pt lst / i p1 p2 an anl ret)
  116.     (setq i -1 p1 (last lst))
  117.     (while(and(not ret)(setq p2(nth(setq i(1+ i))lst)))
  118.       (cond((equal p2 pt 1e-6)(setq ret t))
  119.      (t(setq an(-(angle pt p1)(angle pt p2)))
  120.       (if(equal pi(abs an) 1e-6)
  121.         (setq ret t)
  122.         (setq anl(cons(rem an PI)anl)))))
  123.       (setq p1 p2))
  124.     (cond(ret 0);线上;
  125.    (t(if(equal PI(abs(apply'+ anl))1e-6)1 -1))))


  126. (defun vxs(e / p a b n ob q et d d1 en et)
  127.     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
  128.     (cond((="LWPOLYLINE"et)
  129.     (repeat(length a)(setq b (nth n a) n (+ n 1))
  130.       (if (= 10 (car b))(progn
  131.         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
  132.         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
  133.           (setq p (list q)))))))
  134.    ((="OLYLINE"et)
  135.     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
  136.     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
  137.       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
  138.       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
  139.       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
  140.     (setq p(reverse p))))P)
  141. ;;;;;;;;;;
  142. (vl-load-com)
  143. (defun c:dmfc (  / zxbl pt p1 p2 p3 p4  fchd lst gcz nn i ss  p5);
  144. (setq fchd (getreal "\n请输入回填土压实后厚度(一般0.25米) :"))
  145. (setq zxbl (getint "\n请输入断面纵向比例 1 :"))
  146.   (setq pt (getpoint "\n请点击横断面图上96区顶中桩位置 :"))
  147. (setq p1 (car(entsel "\n请选择96区顶横断面多段线:")))
  148.   (setq p2 (car(entsel "\n请选择左边坡断面多段线:")))
  149.   (setq p3 (car(entsel "\n请选择右边坡横断面多段线:")))
  150.   (setq p4 (car(entsel "\n请选择原地面横断面多段线:")))
  151.   (setq ss(ssadd)) (ssadd p1 ss)(ssadd p2 ss)(ssadd p3 ss)(ssadd p4 ss)
  152.   (LM:outline ss ) (setq p5 (entlast))

  153. (setq lst (vl-sort (vxs p4)(function (lambda (e1 e2) (< (cadr e1) (cadr e2))))))

  154. (setq gcz (* (- (cadr pt)  (cadr(car lst))  ) (/ zxbl 1000.000)  )  )

  155. (setq nn (fix (/ gcz fchd)))
  156. (setq i 0)
  157. (repeat  (- nn 1)
  158.   (setvar "osmode" 16384) (setvar "CMDECHO" 0)
  159. (command "_.copy" p1 "" pt (polar pt (* 1.5 pi ) (/ (* fchd (+ i 1)) (/ zxbl 1000.000)  )   )   "" )
  160.   ;
  161.   (command "_.extend"  p2   "" (list  (entlast)(car(vxs (entlast)))) "" )
  162.   (command "_.extend"  p2   "" (list (entlast) (last(vxs (entlast))) ) "" )

  163.   (command "_.extend"  p3   "" (list  (entlast)(car(vxs (entlast)))) "" )
  164.   (command "_.extend"  p3   "" (list (entlast) (last(vxs (entlast))) ) "" )
  165. (command "_.extend"  p4   "" (list  (entlast)(car(vxs (entlast)))) "" )
  166.   (command "_.extend"  p4   "" (list (entlast) (last(vxs (entlast))) ) "" )
  167.   
  168.   (cond   (  (>=  (poinpl (car(vxs (entlast))) (vxs p5))  0 )                ;

  169.        (command "_.trim"  p4 "" (list (entlast) (last(vxs (entlast))) )  "" )  )

  170. (  (>=  (poinpl (last (vxs (entlast))) (vxs p5))  0 )                ;

  171.        (command "_.trim"  p4 "" (list (entlast) (car(vxs (entlast))) )  "" )  )

  172.     )
  173.   
  174. (setq i (1+ i))


  175.   )
  176. (entdel p5)


  177. (setvar "osmode" 9) (setvar "CMDECHO" 1)
  178. (princ)
  179.   )

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x

评分

参与人数 1明经币 +1 收起 理由
yanshengjiang + 1 同行你好,请问你屏幕左边的工具箱是什么呢.

查看全部评分

 楼主| 发表于 2019-12-26 15:26:55 | 显示全部楼层
李苹果大神 的直线多段线包围盒 DDXBWH

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
 楼主| 发表于 2019-12-30 22:21:04 | 显示全部楼层
本帖最后由 树櫴希德 于 2019-12-31 11:27 编辑

旧版有问题
  1. ;;
  2. ;;;
  3. ;;;    EXTRIM.LSP
  4. ;;;    Copyright ?1999 by Autodesk, Inc.
  5. ;;;
  6. ;;;    Your use of this software is governed by the terms and conditions of the
  7. ;;;    License Agreement you accepted prior to installation of this software.
  8. ;;;    Please note that pursuant to the License Agreement for this software,
  9. ;;;    "[c]opying of this computer program or its documentation except as
  10. ;;;    permitted by this License is copyright infringement under the laws of
  11. ;;;    your country.  If you copy this computer program without permission of
  12. ;;;    Autodesk, you are violating the law."
  13. ;;;
  14. ;;;    AUTODESK PROVIDES THIS PROGRAM "AS IS" AND WITH ALL FAULTS.
  15. ;;;    AUTODESK SPECIFICALLY DISCLAIMS ANY IMPLIED WARRANTY OF
  16. ;;;    MERCHANTABILITY OR FITNESS FOR A PARTICULAR USE.  AUTODESK, INC.
  17. ;;;    DOES NOT WARRANT THAT THE OPERATION OF THE PROGRAM WILL BE
  18. ;;;    UNINTERRUPTED OR ERROR FREE.
  19. ;;;
  20. ;;;    Use, duplication, or disclosure by the U.S. Government is subject to
  21. ;;;    restrictions set forth in FAR 52.227-19 (Commercial Computer
  22. ;;;    Software - Restricted Rights) and DFAR 252.227-7013(c)(1)(ii)
  23. ;;;    (Rights in Technical Data and Computer Software), as applicable.
  24. ;;;
  25. ;;;  ----------------------------------------------------------------


  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27. ;Extended-TRIM - cookie-cutter routine
  28. ;
  29. ;Select a polyline, line, circle or arc and a side to trim on
  30. ;
  31. (defun pzx-extrim (na p1 / na e1 p1 redraw_it lst n )

  32. (acet-error-init (list
  33.                    (list   "cmdecho" 0
  34.                          "highlight" 0
  35.                          "regenmode" 1
  36.                             "osmode" 0
  37.                            "ucsicon" 0
  38.                         "offsetdist" 0
  39.                             "attreq" 0
  40.                           "plinewid" 0
  41.                          "plinetype" 1
  42.                           "gridmode" 0
  43.                            "celtype" "CONTINUOUS"
  44.                          "ucsfollow" 0
  45.                           "limcheck" 0
  46.                    )
  47.                    T     ;flag. True means use undo for error clean up.
  48.                    '(if redraw_it (redraw na 4))
  49.                   );list
  50. );acet-error-init


  51. (princ "\nPick a POLYLINE, LINE, CIRCLE, ARC, ELLIPSE, IMAGE or TEXT for cutting edge...")
  52. ;setq
  53. (if na
  54.     (progn
  55.      (setq e1 (entget na));;setq
  56.      (if (or (equal "TEXT"   (cdr (assoc 0 e1)))
  57.              (equal "MTEXT"  (cdr (assoc 0 e1)))
  58.              (equal "ATTDEF" (cdr (assoc 0 e1)))
  59.              (equal "IMAGE"  (cdr (assoc 0 e1)))
  60.              (equal "INSERT" (cdr (assoc 0 e1)))
  61.              (equal "SOLID"  (cdr (assoc 0 e1)))
  62.              (equal "3DFACE" (cdr (assoc 0 e1)))
  63.              (equal "TRACE"  (cdr (assoc 0 e1)))
  64.          );or
  65.          (progn
  66.           (setq lst (acet-geom-object-point-list na nil))
  67.           (setq n 0)
  68.           (command "_.pline")
  69.           (repeat (length lst)
  70.           (command (nth n lst))
  71.           (setq n (+ n 1));setq
  72.           );repeat
  73.           (if (not (equal (car lst) (last lst) 0.0000001))
  74.               (command "_cl")
  75.               (command "")
  76.           );if
  77.           (setq na (entlast)
  78.                 e1 na
  79.           );setq
  80.          );progn then draw a temp pline to be the cutting edge.
  81.          (setq e1 nil)
  82.      );if
  83.      (redraw na 3)
  84.      (setq redraw_it T)

  85.      ;setq
  86.      (redraw na 4)
  87.      (setq redraw_it nil)
  88.      (if p1 (etrim na p1));if
  89.      (if e1
  90.          (progn
  91.           (if (setq p1 (acet-layer-locked (getvar "clayer")))
  92.               (command "_.layer" "_un" (getvar "clayer") "")
  93.           );if
  94.           (entdel e1)
  95.           (if p1
  96.               (command "_.layer" "_lock" (getvar "clayer") "")
  97.           );if
  98.          );progn then
  99.      );if
  100.     );progn
  101. );if

  102. (acet-error-restore)
  103. (princ)
  104. );defun c:extrim

  105. ;!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  106. ;Entity-TRIM function
  107. ;takes: na - entity name
  108. ;  a - a point, the side to trim on
  109. ;NOTE: This function does not allow for the possible miss of
  110. ;      non-continuous linetypes.
  111. ;
  112. (defun etrim ( na a / la b d e1 lst lst2 n j k m ss na2 na3 na4
  113.                       x y z flag flag2 flag3 zlst vpna vplocked
  114.              )


  115. (setq e1 (entget na));setq
  116. (if (or (setq flag (equal (acet-dxf 0 e1) "OLYLINE"))
  117.         (setq flag (equal (acet-dxf 0 e1) "LWPOLYLINE"))
  118.         (equal (acet-dxf 0 e1) "LINE")
  119.         (equal (acet-dxf 0 e1) "CIRCLE")
  120.         (equal (acet-dxf 0 e1) "ARC")
  121.         (equal (acet-dxf 0 e1) "ELLIPSE")
  122.         (equal (acet-dxf 0 e1) "TEXT")
  123.         (equal (acet-dxf 0 e1) "ATTDEF")
  124.         (equal (acet-dxf 0 e1) "MTEXT")
  125.         (equal (acet-dxf 0 e1) "SPLINE")
  126.     );or
  127.     (progn
  128.      (if (and flag
  129.               (equal 8 (logand 8 (acet-dxf 70 e1)))
  130.          );and
  131.          (setq flag nil)
  132.      );if
  133.      (setq     a (trans a 1 0)
  134.             vpna (acet-currentviewport-ename)
  135.      );setq
  136.      (acet-ucs-cmd (list "_View"))

  137.      (setq   lst (acet-geom-object-point-list na nil)  ;;;find extents of selected cutting edge object
  138.              lst (acet-geom-list-extents lst)
  139.                x (- (car (cadr lst)) (car (car lst)))
  140.                y (- (cadr (cadr lst)) (cadr (car lst)))
  141.                x (* 0.075 x)
  142.                y (* 0.075 y)
  143.                z (list x y)
  144.                x (list (+ (car (cadr lst)) (car z))
  145.                        (+ (cadr (cadr lst)) (cadr z))
  146.                  );list
  147.                y (list (- (car (car lst)) (car z))
  148.                        (- (cadr (car lst)) (cadr z))
  149.                  );list
  150.             zlst (zoom_2_object (list x y))
  151.      );setq
  152.      (if vpna
  153.          (setq vplocked (acet-viewport-lock-set vpna nil)) ;unlock cur viewport if needed.
  154.      );if
  155.      (command "_.zoom" "_w" (car zlst) (cadr zlst))

  156.      (entupd na)                  ;;;update the ent. so it's curves display smoothly

  157.      (setq lst (acet-geom-object-point-list na
  158.                        (/ (acet-geom-pixel-unit) 2.0)
  159.                )
  160.      );setq
  161.      (if (or (not flag)
  162.              (not (acet-geom-self-intersect lst nil))
  163.          );or
  164.          (progn             ;then the object is valid and not a self intersecting polyline.
  165.           (if (and flag
  166.                    (equal (car lst) (last lst) 0.0001)
  167.               );and
  168.               (setq flag3 T);then the polyline could potentialy need a second offset
  169.           );if
  170.           (if (setq la (acet-layer-locked (getvar "clayer")))
  171.               (command "_.layer" "_unl" (getvar "clayer") "")
  172.           );if

  173.           (command "_.pline")
  174.           (setq b nil)
  175.           (setq n 0);setq
  176.           (repeat (length lst)
  177.            (setq d (nth n lst))
  178.            (if (not (equal d b 0.0001))
  179.               (progn
  180.                (command d)
  181.                (setq lst2 (append lst2 (list d)));setq
  182.                (setq b d);setq
  183.               );progn
  184.            );if
  185.            (setq n (+ n 1))
  186.           );repeat
  187.           (command "")
  188.           (setq  na2 (entlast)
  189.                   ss (ssadd)
  190.                   ss (ssadd na2 ss)
  191.                  lst nil
  192.           );setq
  193.           (acet-ss-visible ss 1)
  194.           (setq lst2 (get_fence_points na2 a lst2 flag3 flag));setq

  195.           (if la
  196.               (command "_.layer" "_lock" (getvar "clayer") "")
  197.           );if
  198.           (acet-ucs-cmd (list "_p"))
  199.           ;Move the ents to force a display update of the ents to avoid viewres problems.
  200.           (setvar "highlight" 0)
  201.           (if (setq ss (ssget "_f" (last lst2)))
  202.               (command "_.move" ss "" "0,0,0" "0,0,0")
  203.           );if
  204.           (if flag
  205.               (progn
  206.                (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
  207.                    (command "_.layer" "_unl" (acet-dxf 8 e1) "")
  208.                );if
  209.                (acet-ucs-set-z (acet-dxf 210 e1))
  210.                (command "_.copy" na "" "0,0,0" "0,0,0")
  211.                ;(entdel na)
  212.                (acet-ss-visible (ssadd na (ssadd)) 1);make it invisible for a while.
  213.                                                     ;rk 12:01 PM 3/10/98
  214.                (setq na3 na
  215.                       na (entlast)
  216.                );setq
  217.                (command "_.pedit" na "_w" "0.0" "_x")
  218.                (acet-ucs-cmd (list "_p"))
  219.                (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
  220.               );progn
  221.           );if
  222.           (command "_.trim" na "")
  223.           (setq m (- (length lst2) 1));setq
  224.           (setq k 0)
  225.           (repeat (length lst2)
  226.            (setq lst (nth k lst2))
  227.            (setq a (trans (car lst) 0 1))
  228.            (setq n 1)
  229.            (repeat (- (length lst) 1) ;repeat each fence list
  230.             (setq b (trans (nth n lst) 0 1))
  231.             (if (equal a b 0.0001)
  232.                 (setq flag2 T)
  233.                 (setq flag2 nil)
  234.             );if
  235.             (setq na4 nil);setq
  236.             (setq j 0);setq
  237.             (while (not flag2)       ;repeat each segment of the fence until no new ents are created.
  238.              (setq na4 (entlast));setq
  239.              (command "_F" a b "")
  240.              (if (and (equal na4 (entlast))
  241.                       (or (not (equal k m))
  242.                           (> j 0)
  243.                       );or
  244.                  );and
  245.                  (setq flag2 T)
  246.              );if
  247.              (setq j (+ j 1));setq
  248.             );while
  249.             (setq a b);setq
  250.             (setq n (+ n 1));setq
  251.            );repeat

  252.            (setq k (+ k 1))
  253.           );repeat
  254.           (command "")

  255.           (if flag
  256.               (progn
  257.                (if (setq la (acet-layer-locked (acet-dxf 8 e1)))
  258.                    (command "_.layer" "_unl" (acet-dxf 8 e1) "")
  259.                );if
  260.                (entdel na) ;get rid of the copy

  261.                ;(entdel na3);bring back the original
  262.                (acet-ss-visible (ssadd na3 (ssadd)) 0) ;bring back the original
  263.                                                       ;rk 12:01 PM 3/10/98
  264.                (if la (command "_.layer" "_lock" (acet-dxf 8 e1) ""));if
  265.               );progn
  266.           );if
  267.          );progn
  268.          (progn
  269.           (acet-ucs-cmd (list "_p"))
  270.           (princ "\nSelf intersecting edges are not acceptable.")
  271.          );progn else invalid self intersecting polyline
  272.      );if
  273.      (command "_.zoom" "_p")
  274.      (if vplocked
  275.          (acet-viewport-lock-set vpna T) ;then re-lock the viewport
  276.      );if
  277.     );progn then it's a most likely a valid entity.
  278. );if
  279. );defun etrim

  280. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  281. (defun another_offset ( pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4 / na ss lst da1 da2)

  282. (setq da1 (abs (- a2 a1)));setq
  283. (setq da2 (- (* b (max pl2 pl1))
  284.              (/ (* b (abs (- pl2 pl1)))
  285.                  2.0
  286.              )
  287.           )
  288. );setq
  289. (if (> (abs (- da2 da1))
  290.        (* 0.01 (max a1 a2))
  291.     )
  292.     (progn

  293.      (acet-pline-make (list lst2))
  294.      (setq  na (entlast)
  295.            na2 (entlast)
  296.             ss (ssadd)
  297.             ss (ssadd na ss)
  298.      );setq
  299.      (acet-ss-visible ss 1)
  300.      (command "_.offset" b na2 a "")
  301.      (if (and (not (equal na (entlast)))
  302.               (setq lst3 (acet-geom-vertex-list (entlast)))
  303.               (setq lst3 (intersect_check lst2 lst3 lst4))
  304.          );and
  305.          (progn
  306.           (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
  307.           (command "_.area" "_ob" (entlast))
  308.           (setq pl2 (getvar "perimeter")
  309.                  a2 (getvar "area")
  310.           );setq
  311.           (setq lst (list (acet-geom-vertex-list (list (entlast) 0))));setq
  312.           (entdel (entlast));then offset was a success so delete the ent after getting it's info
  313.          );progn then
  314.          (if (not (equal na (entlast))) (entdel (entlast)));if else
  315.      );if
  316.      (entdel na2)
  317.     );progn then let's do that second offset
  318. );if

  319. lst
  320. );defun another_offset

  321. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  322. (defun get_fence_points ( na2 a lst2 flag plflag / a1 a2 pl1 pl2 b c d n
  323.                                                    lst lst2 lst3 lst4 na
  324.                         )

  325. (if flag
  326.     (progn
  327.      (setq lst2 (cdr lst2));setq
  328.      (repeat (fix (/ (length lst2) 2))
  329.       (setq lst2 (append (cdr lst2) (list (car lst2)));append
  330.       );setq
  331.      );repeat
  332.      (setq lst2 (append lst2 (list (car lst2))));setq
  333.      (command "_.area" "_ob" na2)
  334.      (setq pl1 (getvar "perimeter")
  335.             a1 (getvar "area")
  336.      );setq
  337.     );progn
  338. );if

  339. (setq    a (trans a 0 1)
  340.          b (* (getvar "viewsize") 0.05);initial offset distance
  341.          n 3.0                         ;number of offsets
  342.          d (/ b (- n 1))               ;delta offset
  343.          c (acet-geom-pixel-unit)
  344.       lst4 (acet-geom-view-points)
  345. );setq

  346. (while (> b c)
  347. (setq na (entlast))
  348. (command "_.offset" b na2 a "")
  349. (if (and (not (equal na (entlast)))
  350.          (setq lst3 (acet-geom-vertex-list (entlast)))
  351.          (or (not plflag)
  352.              (setq lst3 (intersect_check lst2 lst3 lst4))
  353.          );or
  354.     );and
  355.     (progn
  356.      (setq lst3 (acet-geom-m-trans lst3 1 0))
  357.      (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
  358.      (if flag
  359.          (progn
  360.           (command "_.area" "_ob" (entlast))
  361.           (setq pl2 (getvar "perimeter")
  362.                  a2 (getvar "area")
  363.           );setq
  364.          );progn
  365.      );if
  366.      (setq lst (append lst (list lst3)));setq
  367.      (entdel (entlast))  ;delete the ent after getting it's vertex info
  368.      (if flag
  369.          (setq lst (append lst
  370.                            (another_offset pl1 pl2 a1 a2 b na2 lst2 a lst3 lst4)
  371.                    );append
  372.          );setq
  373.      );if
  374.     );progn then offset was a success
  375.     (if (not (equal na (entlast))) (entdel (entlast)));if else
  376. );if
  377. (setq b (- b d));setq
  378. );while
  379. (setq na (entlast))
  380. (command "_.offset" c na2 a "")
  381. (if (and (not (equal na (entlast)))
  382.          (setq lst3 (acet-geom-vertex-list (entlast)))
  383.          (or (not plflag)
  384.              (setq lst3 (intersect_check lst2 lst3 lst4))
  385.          );or
  386.     );and
  387.     (progn
  388.      (setq lst3 (acet-geom-m-trans lst3 1 0))
  389.      (acet-ss-visible (ssadd (entlast) (ssadd)) 1)
  390.      (if flag
  391.          (progn
  392.           (command "_.area" "_ob" (entlast))
  393.           (setq pl2 (getvar "perimeter")
  394.                  a2 (getvar "area")
  395.           );setq
  396.          );progn
  397.      );if
  398.      (setq lst (append lst (list lst3)));setq
  399.      (entdel (entlast));then offset was a success so delete the ent after getting it's info
  400.      (if flag
  401.          (setq lst (append lst
  402.                            (another_offset pl1 pl2 a1 a2 c na2 lst2 a lst3 lst4)
  403.                    );append
  404.          );setq
  405.      );if
  406.     );progn then
  407.     (if (not (equal na (entlast))) (entdel (entlast)));if else
  408. );if
  409. (entdel na2)

  410. lst
  411. );defun get_fence_points

  412. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  413. ;returns a list of points on screen if the first two lists do not
  414. ;contain segments that intersect each other.
  415. ;
  416. (defun intersect_check ( lst lst2 lst3 / x x2 y y2 lst4 flag len len2
  417.                                          a aa b bb c d n j)

  418. (setq  len (length lst)
  419.       len2 (length lst2)
  420.          x (car (car lst3))
  421.         x2 (car (cadr lst3))
  422.          y (cadr (car lst3))
  423.         y2 (cadr (cadr lst3))
  424. );setq

  425. (setq n 0);setq
  426. (while (and (not flag)
  427.             (< (+ n 1) len2)
  428.        );and
  429. (setq   aa (nth n lst2)
  430.         bb (nth (+ n 1) lst2)
  431.          a (bns_truncate_2_view aa bb x y x2 y2)
  432.          b (bns_truncate_2_view bb aa x y x2 y2)
  433.       lst4 (append lst4 (list a))
  434. );setq
  435. (if (or (not (equal a aa))
  436.         (not (equal b bb))
  437.     );or
  438.     (setq lst4 (append lst4 (list b)))
  439. );if
  440. (setq j 0);setq
  441. (while (and (not flag)
  442.              (< (+ j 1) len)
  443.         );and
  444. (setq    c (nth j lst)
  445.           d (nth (+ j 1) lst)
  446.        flag (inters a b c d)
  447. );setq

  448. (setq j (+ j 1));setq
  449. );while

  450. (setq n (+ n 1));setq
  451. );while
  452. (if (not (equal b (last lst4)))
  453.     (setq lst4 (append lst4 (list b)));setq
  454. );if
  455. (if (not flag)
  456.     (setq flag lst4)
  457.     (setq flag nil)
  458. );if
  459. flag
  460. );defun intersect_check

  461. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  462. (defun zoom_2_object ( lst / p1 p2 p3 p4 p5 p6 mp dx dy dx2 dy2
  463.                              r1 r2 na e1 x w h dv1 dv2 x
  464.                      )

  465. (setq  lst (acet-geom-m-trans lst 1 2)
  466.          p1 (acet-geom-m-trans (acet-geom-view-points) 1 2)    ;p1 and p2 are the viewpnts
  467.          p2 (cadr p1)
  468.          p1 (car p1)
  469.          p1 (list (car p1) (cadr p1))
  470.          p2 (list (car p2) (cadr p2))
  471. );setq
  472. (if lst
  473.      (progn
  474.       (setq   p5 (acet-geom-list-extents lst)              ;p5 and p6 are the geometry points
  475.               p6 (cadr p5)
  476.               p5 (car p5)
  477.               p5 (list (car p5) (cadr p5))
  478.               p6 (list (car p6) (cadr p6))
  479.               mp (acet-geom-midpoint p5 p6)           ;prepare to resize the geometry rectang to
  480.               dx (- (car p2) (car p1))    ;have the same dy/dx ratio as p1 p2.
  481.               dy (- (cadr p2) (cadr p1))
  482.              dx2 (- (car p6) (car p5))
  483.              dy2 (- (cadr p6) (cadr p5))
  484.       );setq
  485.       (if (equal dx 0.0)  (setq dx 0.000001))  ;just in case div by zero
  486.       (if (equal dx2 0.0) (setq dx2 0.000001))
  487.       (setq   r1 (/ dy dx)
  488.               r2 (/ dy2 dx2)
  489.       );setq
  490.       (if (< r2 r1)
  491.           (setq dy2 (* r1 dx2));then scale dy2 up
  492.           (progn
  493.            (if (equal r1 0.0)  (setq r1 0.000001))  ;just in case div by zero
  494.            (setq dx2 (* dy2 (/ 1.0 r1)));else scale dx2 up
  495.           );progn
  496.       );if
  497.       (setq p5 (list (- (car mp) (/ dx2 1.98))   ;1.98 is used instead of 2.0 to expand
  498.                      (- (cadr mp) (/ dy2 1.98))  ;the rectangle slightly
  499.                );list
  500.             p6 (list (+ (car mp) (/ dx2 1.98))
  501.                      (+ (cadr mp) (/ dy2 1.98))
  502.                );list
  503.       );setq
  504.      );progn then lst
  505. );if
  506. (if (and lst
  507.           (equal 0 (getvar "tilemode"))
  508.           (not (equal 1 (getvar "cvport")))
  509.           (setq na (acet-currentviewport-ename))
  510.      );and
  511.      (progn
  512.       (setq  e1 (entget na)
  513.               x (cdr (assoc 10 e1))
  514.               w (cdr (assoc 40 e1))
  515.               h (cdr (assoc 41 e1))
  516.              p3 (list (- (car x) (/ w 2.0))
  517.                       (- (cadr x) (/ h 2.0))
  518.                 );list
  519.              p4 (list (+ (car x) (/ w 2.0))
  520.                       (+ (cadr x) (/ h 2.0))
  521.                 );list
  522.              p3 (trans p3 3 2)      ;p3 and p4 are the viewport points
  523.              p4 (trans p4 3 2)
  524.             dv1 (acet-geom-delta-vector p1 p3)
  525.             dv2 (acet-geom-delta-vector p2 p4)
  526.               x (distance p1 p2)
  527.       );setq
  528.       (if (equal 0 x) (setq x 0.000001));just in case
  529.       (setq   x (/ (distance p5 p6)
  530.                    x
  531.                 )
  532.             dv1 (acet-geom-vector-scale dv1 x)
  533.             dv2 (acet-geom-vector-scale dv2 x)
  534.              p5 (acet-geom-vector-add p5 dv1)
  535.              p6 (acet-geom-vector-add p6 dv2)
  536.        );setq
  537.      );progn then
  538. );if
  539. (setq p1 (list (car p1) (cadr p1) 0.0)
  540.        p2 (list (car p2) (cadr p2) 0.0)
  541.        p5 (list (car p5) (cadr p5) 0.0)
  542.        p6 (list (car p6) (cadr p6) 0.0)
  543. );setq
  544. (if lst
  545.      (setq lst (list (trans p5 2 1)
  546.                      (trans p6 2 1)
  547.                );list
  548.      );setq
  549.      (setq lst nil)
  550. );if

  551. lst
  552. );defun zoom_2_object


  553. (princ)

  554. ;;;;;;;;;;;;;;;;
  555. (defun LM:outline (sel      /       LM:ssboundingbox  app
  556.        are      box       cmd      dis      enl
  557.        ent      lst       obj      rtn      tmp
  558.       )
  559.   (defun LM:ssboundingbox (s / a b i m n o)
  560.     (repeat (setq i (sslength s))
  561.       (if
  562.   (and
  563.     (setq o (vlax-ename->vla-object (ssname s (setq i (1- i)))))
  564.     (vlax-method-applicable-p o 'getboundingbox)
  565.     (not
  566.       (vl-catch-all-error-p
  567.         (vl-catch-all-apply 'vla-getboundingbox (list o 'a 'b))
  568.       )
  569.     )
  570.   )
  571.    (setq m (cons (vlax-safearray->list a) m)
  572.          n (cons (vlax-safearray->list b) n)
  573.    )
  574.       )
  575.     )
  576.     (if  (and m n)
  577.       (mapcar '(lambda (a b) (apply 'mapcar (cons a b)))
  578.         '(min max)
  579.         (list m n)
  580.       )
  581.     )
  582.   )
  583.   (if (setq box (LM:ssboundingbox sel))
  584.     (progn
  585.       (setq app  (vlax-get-acad-object)
  586.       dis  (/ (apply 'distance box) 20.0)
  587.       lst  (mapcar  '(lambda (a o) (mapcar o a (list dis dis)))
  588.       box
  589.       '(- +)
  590.     )
  591.       are  (apply '* (apply 'mapcar (cons '- (reverse lst))))
  592.       dis  (* dis 1.5)
  593.       ent
  594.     (entmakex
  595.       (append
  596.         '((000 . "LWPOLYLINE")
  597.           (100 . "AcDbEntity")
  598.           (100 . "AcDbPolyline")
  599.           (090 . 4)
  600.           (070 . 1)
  601.          )
  602.         (mapcar '(lambda (x)
  603.              (cons 10 (mapcar '(lambda (y) ((eval y) lst)) x))
  604.            )
  605.           '((caar cadar)
  606.             (caadr cadar)
  607.             (caadr cadadr)
  608.             (caar cadadr)
  609.            )
  610.         )
  611.       )
  612.     )
  613.       )
  614.       (apply
  615.   'vlax-invoke
  616.   (vl-list* app
  617.       'zoomwindow
  618.       (mapcar '(lambda (a o) (mapcar o a (list dis dis 0.0)))
  619.         box
  620.         '(- +)
  621.       )
  622.   )
  623.       )
  624.       (setq cmd  (getvar 'cmdecho)
  625.       enl  (entlast)
  626.       rtn  (ssadd)
  627.       )
  628.       (while (setq tmp (entnext enl)) (setq enl tmp))
  629.       (setvar 'cmdecho 0)
  630.       (command
  631.   "_.-boundary"
  632.   "_a"
  633.   "_b"
  634.   "_n"
  635.   sel
  636.   ent
  637.   ""
  638.   "_i"
  639.   "_y"
  640.   "_o"
  641.   "_p"
  642.   ""
  643.   (trans (mapcar '- (car box) (list (/ dis 3.0) (/ dis 3.0)))
  644.          0
  645.          1
  646.   )
  647.   ""
  648.       )
  649.       (while (< 0 (getvar 'cmdactive)) (command ""))
  650.       (entdel ent)
  651.       (while (setq enl (entnext enl))
  652.   (if (and (vlax-property-available-p
  653.        (setq obj (vlax-ename->vla-object enl))
  654.        'area
  655.      )
  656.      (equal (vla-get-area obj) are 1e-4)
  657.       )
  658.     (entdel enl)
  659.     (ssadd enl rtn)
  660.   )
  661.       )
  662.       (vla-zoomprevious app)
  663.       (setvar 'cmdecho cmd)
  664.       rtn
  665.     )
  666.   )
  667. )

  668. ;(LM:outline(ssget))

  669. (defun PoInPl(pt lst / i p1 p2 an anl ret)
  670.     (setq i -1 p1 (last lst))
  671.     (while(and(not ret)(setq p2(nth(setq i(1+ i))lst)))
  672.       (cond((equal p2 pt 1e-6)(setq ret t))
  673.      (t(setq an(-(angle pt p1)(angle pt p2)))
  674.       (if(equal pi(abs an) 1e-6)
  675.         (setq ret t)
  676.         (setq anl(cons(rem an PI)anl)))))
  677.       (setq p1 p2))
  678.     (cond(ret 0);线上;
  679.    (t(if(equal PI(abs(apply'+ anl))1e-6)1 -1))))


  680. (defun vxs(e / p a b n ob q et d d1 en et)
  681.     (setq a(entget e)ob(vlax-ename->vla-object e)et(cdr(assoc 0 a))n 0 p nil d nil)
  682.     (cond((="LWPOLYLINE"et)
  683.     (repeat(length a)(setq b (nth n a) n (+ n 1))
  684.       (if (= 10 (car b))(progn
  685.         (setq q(list (cadr b) (caddr b))d1(vlax-curve-getDistAtPoint ob q))
  686.         (if p (if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))
  687.           (setq p (list q)))))))
  688.    ((="OLYLINE"et)
  689.     (SETQ EN (ENTGET (SETQ E (ENTNEXT E))))
  690.     (WHILE (/= (CDR (ASSOC 0 EN)) "SEQEND")
  691.       (SETQ q (CDR (ASSOC 10 EN))d1(vlax-curve-getDistAtPoint ob q)q(reverse(cdr(reverse q))))
  692.       (if p(if (not(member d1 d)) (setq p (append p (list q))d (append d (list d1))))(setq p(list q)))
  693.       (SETQ EN (ENTGET (SETQ E (ENTNEXT E)))))
  694.     (setq p(reverse p))))P)
  695. ;;;;;;;;;;
  696. (vl-load-com)
  697. (defun c:dmfc (  / zxbl pt p1 p2 p3 p4  fchd lst gcz nn i ss  p5 ssa);
  698. (setq fchd (getreal "\n请输入回填土压实后厚度(一般0.25米) :"))
  699. (setq zxbl (getint "\n请输入断面纵向比例 1 :"))
  700.   (setq pt (getpoint "\n请点击横断面图上96区顶中桩位置 :"))
  701. (setq p1 (car(entsel "\n请选择96区顶横断面多段线:")))
  702.   (setq p2 (car(entsel "\n请选择左边坡断面多段线:")))
  703.   (setq p3 (car(entsel "\n请选择右边坡横断面多段线:")))
  704.   (setq p4 (car(entsel "\n请选择原地面横断面多段线:")))
  705.   (setq ss(ssadd)) (ssadd p1 ss)(ssadd p2 ss)(ssadd p3 ss)(ssadd p4 ss)
  706.   (LM:outline ss ) (setq p5 (entlast))

  707. (setq lst (vl-sort (vxs p4)(function (lambda (e1 e2) (< (cadr e1) (cadr e2))))))

  708. (setq gcz (* (- (cadr pt)  (cadr(car lst))  ) (/ zxbl 1000.000)  )  )

  709. (setq nn (fix (/ gcz fchd)))
  710. (setq i 0) (setvar "osmode" 16384) (setvar "CMDECHO" 0)
  711. (repeat  (- nn 1)
  712.   
  713. (command "_.copy" p1 "" pt (polar pt (* 1.5 pi ) (/ (* fchd (+ i 1)) (/ zxbl 1000.000)  )   )   "" )
  714.   ;
  715.   (command "_.extend"  p2   "" (list  (entlast)(car(vxs (entlast)))) "" )
  716.   (command "_.extend"  p2   "" (list (entlast) (last(vxs (entlast))) ) "" )

  717.   (command "_.extend"  p3   "" (list  (entlast)(car(vxs (entlast)))) "" )
  718.   (command "_.extend"  p3   "" (list (entlast) (last(vxs (entlast))) ) "" )
  719. (command "_.extend"  p4   "" (list  (entlast)(car(vxs (entlast)))) "" )
  720.   (command "_.extend"  p4   "" (list (entlast) (last(vxs (entlast))) ) "" )
  721.      
  722. (setq i (1+ i))
  723.   )  (setvar "osmode" 16384) (setvar "CMDECHO" 0)
  724.   ;(TrimByFence0 (GetListOfPline0 p5))
  725. ;(entdel p5)
  726.    (pzx-extrim p5  (polar pt (* 0.5 pi ) (/ (* fchd 3) (/ zxbl 1000.000)  )   ) )

  727. (setvar "osmode" 9) (setvar "CMDECHO" 1)
  728. (princ)
  729.   )

本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?注册

x
发表于 2020-1-13 09:34:37 | 显示全部楼层

非常棒的创新。。。。。。。
发表于 2020-2-29 08:42:03 | 显示全部楼层
大神你好,我不会lisp,我一直用的VBA,我也想做一个CAD提取分层线信息到Excel以便于参与水准以及坐标的计算的小插件,现在我遇到的问题是没办法再次延伸或者剪切掉重新生成的多段线,卡住了,如果用纯数学的方式判断有点复杂。能帮我看看吗?我的代码如下:
  1. Sub zcx()
  2. Dim i As Long
  3. Dim j As Long
  4. Dim ch As Double
  5. ch = ThisDrawing.Utility.GetReal("请输入层厚:")
  6. '定义路面中心点,每层中心点
  7. Dim pt1 As Variant
  8. Dim ptn(0 To 2) As Double
  9. '定义结构层线;左右边坡线;地面线
  10. Dim jgc As AcadLWPolyline
  11. Dim zbp As Object
  12. Dim ybp As Object
  13. Dim dmx As Object
  14. ThisDrawing.Utility.GetEntity jgc, pt1, "拾取结构层线(确保其为一根多段线):"
  15. ThisDrawing.Utility.GetEntity zbp, pt1, "拾取左边坡:"
  16. ThisDrawing.Utility.GetEntity ybp, pt1, "拾取右边坡:"
  17. ThisDrawing.Utility.GetEntity dmx, pt1, "拾取地面线:"
  18. '求与边坡的交点
  19. Dim zbpjd As Variant
  20. Dim ybpjd As Variant
  21. Dim dmjd As Variant
  22. Dim fcx() As Double
  23. Dim fch As Integer '分层的层号,从上到下为负1...负N层(倒数第一至倒数第N层)

  24. '----先复制下移结构层----
  25. j = 1
  26. For i = 1 To (UBound(jgc.Coordinates) + 1) Step 2
  27.     ReDim Preserve fcx(1 To (UBound(jgc.Coordinates) + 1))
  28.     fcx(j) = jgc.Coordinates(i - 1)
  29.     fcx(j + 1) = jgc.Coordinates(i) - ch
  30.     j = j + 2
  31. Next i
  32. Set jgc = ThisDrawing.ModelSpace.AddLightWeightPolyline(fcx)

  33. zbpjd = jgc.IntersectWith(zbp, acExtendThisEntity)
  34. ybpjd = jgc.IntersectWith(ybp, acExtendThisEntity)
  35. dmjd = jgc.IntersectWith(dmx, acExtendThisEntity)

  36. '接下来我就不知道怎么延伸重新生成的多段线到边坡或者到地面线了能帮我看看吗?

  37. Stop
  38. End Sub


发表于 2020-3-2 13:49:34 | 显示全部楼层
有挡墙的路基,选择起来更复杂,判断也比较复杂,路肩墙桩板墙或者路堤墙还要与边坡判断,我已经放弃了。谢谢
发表于 2020-7-27 22:48:33 | 显示全部楼层
群主可以出一个工具箱了,
发表于 2020-9-6 12:27:06 来自手机 | 显示全部楼层
好像写过一个提取到表的
发表于 2020-10-30 12:18:36 | 显示全部楼层
楼主问啥每次发帖 后面都要带个问号?  

填方路基横断面自动分层?
发表于 2024-6-25 21:09:35 | 显示全部楼层

能和路基分层偏距高程两个插件融合就相当完美了
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-5 19:38 , Processed in 0.230916 second(s), 28 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表