明经CAD社区

 找回密码
 注册

QQ登录

只需一步,快速开始

搜索
查看: 1982|回复: 10

根据两期间三角网画开挖零界线

[复制链接]
发表于 2016-10-22 16:47:56 | 显示全部楼层 |阅读模式
本帖最后由 树櫴希德 于 2016-10-27 21:25 编辑

根据两期间三角网画开挖零界线-没有成功 用了院长 73哥 生无可恋等大侠的函数  谁能改到能用 ?纯属研究好玩
  1. <blockquote>(defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点

本帖子中包含更多资源

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

x
发表于 2016-10-24 21:26:30 | 显示全部楼层
先发帖占座位,等有时间了研究一下。
楼主可以说说你的思路和算法,方便后面的人快速熟悉;
 楼主| 发表于 2016-10-25 08:36:29 | 显示全部楼层
[x_s_s_1]生无可恋TEMP函数是根据,两个三维点和一个三点三维面丢交点函数 73哥POINPL是判断点在线内外函数 院长那个xyp-IntersWith2Ptn 两点表连线的交点表 求两个三角形平面交集 是先生成两个点表的闭合多段线 再转成面域 然后面域求交集 交集可能为空  交集面域转多段线RTP 然后FOREACH 三角网点表 逐一判断与之相交三角形。。。。。
 楼主| 发表于 2017-10-12 11:39:22 | 显示全部楼层

  1. ;;;by Gu_xl
  2. (defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
  3.   (setvar "CMDECHO" 0)
  4.   (command "layer" "m" "bgGCD" "c" "7" "" "L" "CONTINUOUS" ""  "")
  5.   (if height
  6.     (setq height (rtos height 2 3));3为高程注记位数
  7.     (setq height "")
  8.   )
  9.   (regapp "SOUTH")
  10.   
  11.   ;;;检查字体 "HZ" 是否存在
  12.   (if (not (tblobjname "style" "HZ"))
  13.     (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
  14.   )
  15.   ;;;检查是否存在高程点图块定义
  16.   (if (not (tblobjname "block" "GC200"))
  17.     (progn
  18.       (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
  19.       (setq obj
  20.         (vla-AddPolyline
  21.            blkdef
  22.            (vlax-make-variant
  23.               (vlax-safearray-fill
  24.                  (vlax-make-safearray vlax-vbdouble (cons 0 5))
  25.                  '(-0.2 0 0 0.2 0 0)
  26.               )
  27.            )
  28.         )
  29.       )
  30.       (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
  31.       (vla-put-Closed obj :vlax-true)
  32.       (vla-put-ConstantWidth obj 0.4)
  33.     )
  34.   )
  35.   ;;;插入块
  36.   (entmake (list
  37.              '(0 . "INSERT")
  38.              '(100 . "AcDbEntity")
  39.              '(100 . "AcDbBlockReference")
  40.              '(66 . 1);;;属性跟随标志,1跟随,0不跟随
  41.               (cons 2 "GC200")
  42.               (cons 10 inspt)
  43.               (cons 41 scale)
  44.               (cons 42 scale)
  45.               (cons 43 scale)
  46.               (list -3 '("SOUTH" (1000 . "202101")))
  47.            )
  48.   )
  49.   ;;;插入属性
  50.   (entmake (list
  51.              '(0 . "ATTRIB")
  52.              '(100 . "AcDbEntity")
  53.              '(100 . "AcDbText")
  54.               (cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
  55.               (cons 40 (* 2.0 scale))
  56.               (cons 50 0)
  57.               (cons 41 0.8)
  58.               (cons 51 0)
  59.               (cons 1 height)
  60.               (cons 7 "HZ")
  61.        (cons 62 3)
  62.               (cons 72 0)
  63.               (cons 11 pt)
  64.               '(100 . "AcDbAttribute")
  65.               (cons 2 "height")
  66.               (cons 70  0)
  67.               (cons 74 2)
  68.            )
  69.    )
  70.    ;;;结束标志
  71.    (entmake '((0 . "SEQEND")))
  72.    (princ)
  73. )
  74. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



  75. ;|;;===========================================================================
  76.       通用函数                                                                ;
  77. 功能:求两个线条对象的交点                                                    ;
  78.       适用对象: Line、Circle、Arc、Ellipse、Polyline、                        ;
  79.       LWPolyline、3dPolyline、Spline                                          ;
  80. 参数:OBJ1   ----对象1                                                        ;
  81.       OBJ2   ----对象2                                                        ;
  82.       Extend ----延伸选项                                                     ;
  83.                  0  acExtendNone                                              ;
  84.                  1  acExtendThisEntity                                        ;
  85.                  2  acExtendOtherEntity                                       ;
  86.                  3  acExtendBoth                                              ;
  87.       ZZZ    ----输出选项                                                     ;
  88.                  "=0"  Z值取0                                                 ;
  89.                  "F1"  取第一个对象上的点                                     ;
  90.                  "F2"  取第二个对象上的点                                     ;
  91.                  "MAX" 取Z值大者                                              ;
  92.                  "MIN" 取Z值小者                                              ;
  93.       Fuzz   ----允许偏差值                                                   ;
  94. 返回:若成功,返回点位表;否则返回nil
  95. 日期:zml84 于2007-11-05
  96. ;;|;
  97. (vl-load-com)
  98. (defun ZL-GETINTERS (OBJ1   OBJ2   EXTEND ZZZ  FUZZ /      ENT1
  99.        ENT2   PT10   PT11   PT20  PT21 OBJ11  OBJ22
  100.        ARRAY  LST    LST_PT I  PT PT1    PT2
  101.        Z1     Z2
  102.       )
  103.     ;;0、对参数的格式化处理
  104.     (if (and (= (type EXTEND) 'INT)
  105.       (<= 0 EXTEND 3)
  106. )
  107. ()
  108. (setq EXTEND 0)
  109.     )
  110.     (setq ZZZ (strcase ZZZ))
  111.     ;;======================
  112.     ;;1、获取交点集合>>>>>>>
  113.     (if (and (= (vla-get-objectname OBJ1) "AcDbLine")
  114.       (= (vla-get-objectname OBJ2) "AcDbLine")
  115. )
  116. ;;对直线对象(line) 特别处理
  117. (progn
  118.      (setq ENT1 (entget (vlax-vla-object->ename OBJ1))
  119.     ENT2 (entget (vlax-vla-object->ename OBJ2))
  120.      )
  121.      (setq PT10 (assoc 10 ENT1)
  122.     PT11 (assoc 11 ENT1)
  123.     PT20 (assoc 10 ENT2)
  124.     PT21 (assoc 11 ENT2)
  125.      )
  126.      ;;去除Z坐标
  127.      (setq PT10 (list (cadr PT10) (caddr PT10))
  128.     PT11 (list (cadr PT11) (caddr PT11))
  129.     PT20 (list (cadr PT20) (caddr PT20))
  130.     PT21 (list (cadr PT21) (caddr PT21))
  131.      )
  132.      (setq LST (inters PT10 PT11 PT20 PT21 t))
  133.      (if LST
  134.   (setq LST (append LST '(0)))
  135.      )
  136. )
  137. (progn
  138.      ;;=====================
  139.      ;;复制实体
  140.      (setq OBJ11 (vla-copy OBJ1)
  141.     OBJ22 (vla-copy OBJ2)
  142.      )
  143.      ;;向xy平面投影,将Z坐标改为0
  144.      (TOXY OBJ11)
  145.      (TOXY OBJ22)
  146.      ;;获取交点集合
  147.      (setq ARRAY (vla-intersectwith OBJ11 OBJ22 EXTEND))
  148.      ;;删除复制后的对象
  149.      (vla-delete OBJ11)
  150.      (vla-delete OBJ22)
  151.      ;;由数组转换为表
  152.      (if (and ARRAY
  153.        (> (vlax-safearray-get-u-bound
  154.        (vlax-variant-value ARRAY)
  155.        1
  156.    )
  157.    1
  158.        )
  159.   )
  160.   (progn
  161.       (setq LST (vlax-safearray->list
  162.       (vlax-variant-value ARRAY)
  163.          )
  164.       )
  165.   )
  166.      )
  167. )
  168.     )
  169.     ;;======================
  170.     ;;2、分析整理>>>>>>>
  171.     (setq LST_PT '())
  172.     (if LST
  173. (progn
  174.      (setq I 0)
  175.      (repeat (/ (length LST) 3)
  176.   ;;2.1 获取当前点位
  177.   (setq PT (list (nth I LST)
  178.           (nth (+ 1 I) LST)
  179.           (nth (+ 2 I) LST)
  180.     )
  181.   )
  182.   ;;2.2 获取对象上对应点位
  183.   (setq PT1 (vlax-curve-getclosestpointtoprojection
  184.          OBJ1
  185.          PT
  186.          '(0 0 1)
  187.      )
  188.         PT2 (vlax-curve-getclosestpointtoprojection
  189.          OBJ2
  190.          PT
  191.          '(0 0 1)
  192.      )
  193.   )
  194.   (setq Z1 (caddr PT1)
  195.         Z2 (caddr PT2)
  196.   )

  197.   ;;2.3 效验偏差值
  198.   ;;就是说:过滤:参数中有偏差值选项,却不满足要求的点位
  199.   (if (and FUZZ
  200.     (or (= (type FUZZ) 'REAL)
  201.         (= (type FUZZ) 'INT)
  202.     )
  203.     (not (equal Z1 Z2 FUZZ))
  204.       )
  205.       ;; 空处理
  206.       ()
  207.       ;;2.4 对输出选项的处理
  208.       (progn
  209.    (cond
  210.        ((= ZZZ "F1")
  211.         (setq PT PT1)
  212.        )
  213.        ((= ZZZ "F2")
  214.         (setq PT PT2)
  215.        )
  216.        ((= ZZZ "MAX")
  217.         (if (> Z1 Z2)
  218.      (setq PT PT1)
  219.      (setq PT PT2)
  220.         )
  221.        )
  222.        ((= ZZZ "MIN")
  223.         (if (< Z1 Z2)
  224.      (setq PT PT1)
  225.      (setq PT PT2)
  226.         )
  227.        )
  228.        (t
  229.         (setq PT PT)
  230.        )
  231.    ) ;_结束cond
  232.    (if (member PT LST_PT)
  233.        ()
  234.        (setq LST_PT (cons PT LST_PT))
  235.    )
  236.       ) ;_结束progn
  237.   ) ;_结束if
  238.   (setq I (+ I 3))
  239.      ) ;_结束repeat
  240. ) ;_结束progn
  241.     ) ;_结束if
  242.     ;;3、返回结果>>>>>
  243.     LST_PT
  244. ) ;_结束defun
  245. ;;;============================================================
  246. ;;;功能:曲线实体上每个控制点的z坐标值置为0.0                  
  247. (defun TOXY (OBJ / NAME PT1 TP2)
  248.     ;;取得实体的类型名称
  249.     (setq NAME (vla-get-objectname OBJ))
  250.     (cond
  251. ;;类型1
  252. ;;直线(line)
  253. ((= NAME "AcDbLine")
  254.   ;;取得直线的起终点坐标
  255.   (setq PT1 (vlax-variant-value (vla-get-startpoint OBJ))
  256.         PT2 (vlax-variant-value (vla-get-endpoint OBJ))
  257.   )
  258.   ;;改变z值为0.0
  259.   (vlax-safearray-put-element PT1 2 0.0)
  260.   (vlax-safearray-put-element PT2 2 0.0)
  261.   (vla-put-startpoint OBJ PT1)
  262.   (vla-put-endpoint OBJ PT2)
  263. )
  264. ;;类型2
  265. ;;圆(circle)
  266. ;;圆弧(arc)
  267. ;;椭圆及椭圆弧(ellipse)
  268. ((or (= NAME "AcDbCircle")
  269.       (= NAME "AcDbArc")
  270.       (= NAME "AcDbEllipse")
  271.   )
  272.   ;;取得中心点座标
  273.   (setq PT1 (vlax-variant-value (vla-get-center OBJ)))
  274.   ;;改变中心点座标z值为0.0
  275.   (vlax-safearray-put-element PT1 2 0.0)
  276.   (vla-put-center OBJ PT1)
  277. )
  278. ;;类型3
  279. ;;多段线(polyline、lwpolyline)
  280. ;;拟合的2维多段线(polyline、lwpolyline)
  281. ((or (= NAME "AcDbPolyline")
  282.       (= NAME "AcDb2dPolyline")
  283.   )
  284.   ;;改变标高值为0.0
  285.   (vla-put-elevation OBJ 0.0)
  286. )
  287. ;;类型4
  288. ;;三维多段线(3dpolyline)  
  289. ((= NAME "AcDb3dPolyline")
  290.   ;;取得3维多段线的控制点
  291.   (setq PT1 (vlax-variant-value (vla-get-coordinates OBJ))
  292.         I   0
  293.   )
  294.   (repeat (/ (length (vlax-safearray->list PT1)) 3)
  295.       (vlax-safearray-put-element PT1 (+ I 2) 0.0)
  296.       (setq I (+ I 3))
  297.   )
  298.   (vla-put-coordinates OBJ PT1)
  299. )
  300. ;;类型5
  301. ;;样条曲线(Spline)
  302. ((= NAME "AcDbSpline")
  303.   ;;取得样条曲线的拟合点
  304.   ;;改变每个拟合点的z值为0.0
  305.   (setq PT1 (vlax-variant-value (vla-get-fitpoints OBJ))
  306.         I   0
  307.   )
  308.   (repeat (vla-get-numberoffitpoints OBJ)
  309.       (vlax-safearray-put-element PT1 (+ I 2) 0.0)
  310.       (setq I (+ I 3))
  311.   )
  312.   (vla-put-fitpoints OBJ PT1)
  313.   ;;取得样条曲线的控制点
  314.   ;;改变每个控制点的z值为0.0  
  315.   (setq
  316.       PT2 (vlax-variant-value (vla-get-controlpoints OBJ))
  317.       I  0
  318.   )
  319.   (repeat (vla-get-numberofcontrolpoints OBJ)
  320.       (vlax-safearray-put-element PT2 (+ I 2) 0.0)
  321.       (setq I (+ I 3))
  322.   )
  323.   (vla-put-controlpoints OBJ PT2)
  324. )
  325. (t NIL)
  326.     )
  327. ) ;_结束defun
  328. ;(setq ppzzxx (ZL-GETINTERS (vlax-ename->vla-object(car (entsel) ) ) (vlax-ename->vla-object(car (entsel) ) ) 0 "f2" nil)   )
  329. ;选择集与对象名表互转
  330. (defun cx-ss2en
  331.   (ss / enlst)
  332.   (cond
  333.     ((= (type ss) 'PICKSET)
  334.       (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
  335.     )
  336.     ((= (type ss) 'LIST)
  337.       (setq enlst (ssadd))
  338.       (last (mapcar '(lambda (x) (ssadd x enlst)) ss))
  339.     )
  340.     ((='ename(type ss))
  341.       (ssadd ss)
  342.     )
  343.   )
  344. );;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  345. (defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点
  346.     (setq a(vlax-ename->vla-object e)
  347.   q(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates a)))
  348.     m(vla-get-objectname a)a 0
  349.     m(if(= m"AcDb3dPolyline")3 2))
  350.     (repeat(/(length q)m)
  351.       (cond((= m 2)(setq p1(list(nth a q)(nth(+ a 1)q))))
  352.      ((= m 3)(setq p1(list(nth a q)(nth(+ a 1)q)(nth(+ a 2)q)))))
  353.       (setq p(if (member p1 p)p (append p(list p1)))
  354.       a(+ a m)))
  355.     p)

  356. (defun xyp-Pline (lst / lst pt)
  357. (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst))'(70 . 129))
  358.       (mapcar '(lambda (pt)(cons 10 pt)) lst ))
  359.   ) (vl-cmdf "_.region" (entlast) "") (entlast)
  360. )

  361. (defun xyp-get-Inters (s1 s2 / s1 s2 s3)
  362.   (vl-cmdf "_.intersect" s1 s2 "") ;
  363. (if (equal (cdr(cadr(entget(entlast) ))) "REGION") (setq s3 (entlast))  (setq s3 nil))
  364.   s3
  365.   )
  366. (defun xyp-erase (lst / lst)
  367.   (foreach n lst
  368.      (entdel n))
  369.   )
  370. ;;;;;;;;;;;;;;;;;;;;;;
  371. (defun rtp ( en / ss n k en spg)
  372.   (setvar "cmdecho" 0)

  373.   (command "layer" "n" "PG" "c" "6" "PG" "s" "PG" "")
  374.   (command "layer" "n" "PG1" "c" "7" "PG1" "s" "PG1" "")
  375.   (command "peditaccept" 1)
  376.   
  377.    
  378.     (command "chprop" en "" "la" "PG1" "")
  379.     (command "explode" en)
  380.     (setq spg (ssget "X" '((8 . "PG1"))))
  381.     (command "pedit" "m" spg "" "j" "0" "")
  382.     (setq spg (ssget "X" '((8 . "PG1"))))
  383.     (command "chprop" spg "" "la" "PG" "")
  384.    
  385.   
  386.   (command "peditaccept" 0)
  387.   (command "layer" "s" "PG" "")
  388.   (command "purge" "la" "" "no")
  389.   (setvar "cmdecho" 1)
  390.   (entlast)
  391. )
  392. ;;;;;;;;;;;;;;;;;;;;;;;
  393. (defun REGIONlist(en / pt x-pt y-pt pt1 en1 en1get 10list  )
  394. ;(setq en(car(entsel)))
  395. (setq pt(vla-get-Centroid (vlax-ename->vla-object en)))
  396. (setq x-pt (vlax-safearray-get-element (vlax-variant-value pt) 0))
  397. (setq y-pt (vlax-safearray-get-element (vlax-variant-value pt) 1))
  398. (setq pt1(list x-pt y-pt 0.0))
  399. (command "BOUNDARY"  pt1 "")
  400.   (vla-delete(vlax-ename->vla-object en) )
  401. (setq en1(entlast))
  402. (setq en1get(entget en1))
  403. (setq 10list nil)
  404. (foreach n en1get(if (= 10 (car n))
  405.           (setq 10list(cons (cdr n) 10list ))))
  406. (vla-delete(vlax-ename->vla-object en1) ) ;(entdel en1)
  407.   10list
  408.   )
  409. ;; xyp-IntersWith2Ptn 两点表连线的交点表 (xyp-IntersWith2Ptn ptn1 ptn2)
  410. (defun MJD (ptn1 ptn2 / s1 s2 ptn11 ptn pzx)
  411.   (setq  s1  (xyp-Pline ptn1 )
  412.   s2  (xyp-Pline ptn2 )
  413.   ptn11 (xyp-get-Inters s1 s2 )
  414.   ptn  (REGIONlist ptn11)
  415.   )
  416.   (xyp-erase (list s1 s2))
  417.   
  418.   (vla-delete(vlax-ename->vla-object ptn11) )
  419.   ptn
  420. )


  421. (defun PoInPl(pt p / n i va ang);;该过程由 StEf  44604813提供,本人只是把输出由原来的t,nil改为了-1,0,1
  422.       (setq n(length pt)
  423.       pt(append pt(list(car pt)))i 0 ang 0)
  424.       (while(< i n)
  425.   (setq va(-(angle p(nth i pt))(angle p(nth(1+ i)pt))))
  426.   (if (<(abs(-(abs va)pi))0.000001)(setq ang 2 i n)
  427.     (progn(cond((> va pi)(setq va (- va pi)))
  428.          ((< va (* -1 pi))(setq va (+ va pi))))
  429.       (setq ang(+ ang va)i(1+ i)))))
  430.       (if(= ang 2)0
  431.   (if(<(abs(-(abs ang) pi))0.000001)1 -1))
  432.       );defun
  433. ;;;改改更贱康
  434. (defun temp (pa pb p0 p1 p2 / MAT:vxv {vp} {v} a b)
  435.   (defun MAT:vxv (u v)
  436.     (list
  437.       (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
  438.       (- (* (car v) (caddr u)) (* (car u) (caddr v)))
  439.       (- (* (car u) (cadr v)) (* (car v) (cadr u)))
  440.     )
  441.   )
  442.   (setq {vp} (MAT:vxv (mapcar '- p1 p0) (mapcar '- p2 p0)))
  443.   (setq {v} (mapcar '- pa pb))
  444.   (setq  a (apply '+
  445. (mapcar '(lambda (n m vp) (* (- n m) vp)) p0 pa {vp})
  446.   )
  447.   )
  448.   (setq b (apply '+ (mapcar '* {vp} {v})))
  449.   (if (equal b 0.0 1e-6)
  450.     nil
  451.     (mapcar '(lambda (m v) (+ m (* v (/ a b)))) pa {v})
  452.   )
  453. )


  454. ;(setq ptlist (plinexy(car(entsel))) )
  455. ;(setq p1 (getpoint "\n请选择第一点:" ))
  456. ;(setq p2 (getpoint "\n请选择第2点:" ))
  457. ;(setq pzx (temp p1 p2  (car ptlist) (cadr ptlist)(caddr ptlist)) )


  458. ;(entmake (list '(0 . "polyline") (cons 10 p1) (cons 10 p2) (cons 10 pzx)))
  459. ;(command "_.3dpoly" p1 pzx p2 "")
  460. ;(setq opo '((100 200 10)(10 20 11)(23 25 6)))

  461. ;(mapcar '(lambda (x )  (vl-remove (last x)x)  )opo)   
  462. (defun c:kwljx ( / ssa ssb ii no en ptb pzx en1 ptb1 pzx1 a1 a2 a3 x n h a4 a5 a6 ppp PPPP P PPPPP I ooxx blc scale b m)
  463.   (setvar "osmode" 16384)
  464. (setq ssa (ssget '((0 . "POLYLINE") (8 . "sjw"))))
  465. (setq ssb (ssget '((0 . "POLYLINE") (8 . "sjw1"))))
  466.                 (setq ii   0
  467.                       no  0
  468.                   )
  469.                   
  470. (setq blc (getint "\n请输入比例尺1:<500>"))
  471.   (if (= blc nil)(setq blc 500))
  472.   (setvar 'userr1 blc);设置比例尺
  473. (setq scale (* 0.001 blc));缩放比例

  474. (mapcar '(lambda (x)   
  475.   ;;;;=====
  476.      (setq pzx (plinexy x))
  477.    (foreach n (cx-ss2en ssb)
  478.      (setq pzx1 (plinexy n))
  479.   (if  (or  (/=  (ZL-GETINTERS (vlax-ename->vla-object x) (vlax-ename->vla-object n ) 0 "f2" nil) nil)
  480.     (and (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx) (vl-remove (last (car pzx1)) (car pzx1))  )0)
  481.     (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx) (vl-remove (last (cadr pzx1)) (cadr pzx1))  )0)
  482.     (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx) (vl-remove (last (caddr pzx1)) (caddr pzx1))  )0)
  483.       )
  484.     (and (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx1) (vl-remove (last (car pzx)) (car pzx))  )0)
  485.     (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx1) (vl-remove (last (cadr pzx)) (cadr pzx))  )0)
  486.     (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx1) (vl-remove (last (caddr pzx)) (caddr pzx))  )0)
  487.       )  
  488.    )
  489.     (progn
  490.          (setq a1 (temp (car pzx1)(cadr pzx1) (car pzx) (cadr pzx)  (caddr pzx) ))
  491.     (setq a2 (temp (car pzx1)(caddr pzx1) (car pzx) (cadr pzx)  (caddr pzx) ))
  492.      (setq a3 (temp (caddr pzx1)(cadr pzx1) (car pzx) (cadr pzx)  (caddr pzx) ))
  493.      
  494. (setq a4 (temp (car pzx)(cadr pzx) (car pzx1) (cadr pzx1)  (caddr pzx1) ))
  495.     (setq a5 (temp (car pzx)(caddr pzx) (car pzx1) (cadr pzx1)  (caddr pzx1) ))
  496.      (setq a6 (temp (caddr pzx)(cadr pzx) (car pzx1) (cadr pzx1)  (caddr pzx1) ))
  497.      ;(print x) (print n)
  498.      (setq ppp (MJD(mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx)(mapcar '(lambda (h)  (vl-remove (last h)h)  )pzx1) ) )
  499.        ;(print a1) (print a2)(print a3)(print a4)(print a5)(print a6)
  500.        ;(PRINT PPP)
  501.      ;(command "_.3dpoly" a1 a2 a3 a4 a5 a6 "")
  502.      (SETQ PPPP (vl-remove 'nil (LIST a1 a2 a3 a4 a5 a6))) ;(xyp-pline (mapcar '(lambda (h)  (vl-remove (last h)h)  )pppp))
  503.      (SETQ PPPPP '())(SETQ I 0)
  504.       (REPEAT (LENGTH PPPP)
  505.   (setq ooxx (nth i pppp))
  506.     (if (and (/= ooxx nil)
  507.     (>= (poinpl ppp (vl-remove (last ooxx)ooxx)  )0)) (setq ppppp (append ppppp (list ooxx) )) )
  508.         (SETQ I (1+ I))
  509.   ) (print ppppp) (xyp-pline  (mapcar '(lambda (b)  (vl-remove (last b)b)  )ppppp))   
  510.      (mapcar '(lambda (m)  (gxl-cs:gcd m (last m) scale)  )ppppp)
  511.       )
  512.    )


  513.      
  514.    
  515.      );;;;======  
  516.   )
  517. (cx-ss2en ssa)
  518.   )


  519. (princ)
  520.   )


 楼主| 发表于 2017-10-12 11:40:29 | 显示全部楼层

  1. (defun c:r2pl (/ *error* arcbugle acdoc space ss j) ;;;面域转多段线
  2. (vl-load-com)
  3. ;;;***************************************************************;;;
  4.   (defun *error* (msg)
  5.     (if        (/= msg "Function cancelled")
  6.       (princ (strcat "\nError: " msg))
  7.     )
  8.     (vla-EndUndoMark
  9.       (vla-get-ActiveDocument (vlax-get-acad-object))
  10.     )
  11.     (princ)
  12.   )
  13. (defun arcbulge (arc)
  14.     (- 0 (/ (sin (/ (vla-get-TotalAngle arc) 4))
  15.        (cos (/ (vla-get-TotalAngle arc) 4))
  16.     ))
  17. );defun arcbulge
  18. (defun addPL (lst / pt en)
  19.   (setq en (entmakex (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (/ (length lst) 2)) (cons 70 1)) lst)
  20.   ))
  21.   en
  22. );defun addPL
  23. (defun apss (ss / en i)
  24.   (repeat (setq i (sslength ss))
  25.     (setq en (ssname ss (setq i (1- i))))
  26.     (reg2pl en)
  27.   )
  28. );defun apss
  29. (defun lk-list (lst / lastpt a )
  30.   (setq rlst (car lst))
  31.   (setq lastpt (caddr rlst))
  32.   (setq rlst (reverse rlst))
  33.   (setq lst (cdr lst))
  34.   (while lst
  35.     (setq a (car lst))
  36.         (cond
  37.           ((equal (car a) lastpt 0.00001)
  38.             (setq rlst (cons (cadr a) rlst))
  39.                 (setq lastpt (caddr a))
  40.                 (setq rlst (cons lastpt rlst))
  41.                 (setq lst (cdr lst))
  42.           )
  43.           ((equal (caddr a) lastpt 0.00001)
  44.             (setq rlst (cons (cadr a) rlst))
  45.                 (setq lastpt (car a))
  46.                 (setq rlst (cons lastpt rlst))
  47.                 (setq lst (cdr lst))
  48.           )
  49.           (T
  50.                 (setq lst (cdr (reverse (cons a (reverse lst)))))
  51.           )
  52.         );cond
  53.   );while lst
  54.   (setq rlst (reverse (cdr rlst)))
  55.   rlst
  56. );defun lk-list
  57. (defun reg2pl (obj / n reg expl plst)
  58.   (if (= 'ename (type obj))
  59.     (setq obj (vlax-ename->vla-object obj))
  60.   )
  61.     (setq reg obj)
  62.         (setq expl (vlax-invoke reg 'Explode))
  63.                 ;;;;;;;;;;;;;;;;;;;
  64.     (if (= (vla-get-ObjectName (car expl)) "AcDbRegion")
  65.       (progn
  66.             (setq expl1 expl)
  67.                 (while expl1
  68.                   (reg2pl (car expl1))
  69.                   (setq expl1 (cdr expl1))
  70.                 )
  71.                 (vla-delete obj)
  72.           )
  73.           (progn
  74.         (if (vl-every '(lambda (x)
  75.                          (or
  76.                            (= (vla-get-ObjectName x) "AcDbLine")
  77.                            (= (vla-get-ObjectName x) "AcDbArc")
  78.                          )
  79.                        )
  80.                       expl
  81.             )
  82.           (progn
  83.             (vla-delete reg)
  84.             (setq plst (lk-list (mapcar '(lambda        (x)
  85.                                   (list        
  86.                                         (cons 10 (reverse (cdr (reverse (vlax-get x 'StartPoint)))))
  87.                                                                                 (if (= (vla-get-ObjectName x) "AcDbArc")
  88.                                           (setq blst (cons 42 (arcbulge x)))
  89.                                                                                   (setq blst (cons 42 0))
  90.                                         )
  91.                                         (cons 10 (reverse (cdr (reverse (vlax-get x 'EndPoint)))))
  92.                                   )
  93.                                 )
  94.                                expl
  95.                        )
  96.             ))
  97.             (addpl plst)
  98.           )
  99.          
  100.         )
  101.                 (mapcar 'vla-delete expl)
  102.     );progn
  103.   );if
  104. );reg2pl
  105. ;;;***************************************************************;;;
  106.   (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
  107.         space (if (= 1 (getvar "CVPORT"))
  108.                   (vla-get-PaperSpace acdoc)
  109.                   (vla-get-ModelSpace acdoc)
  110.                )
  111.   )
  112.   (vla-StartUndoMark acdoc)
  113.   (setq j 0)
  114.   (while (setq ss (ssget ":s" '((0 . "REGION"))))
  115.     (setq j (+ (sslength ss) j))
  116.     (apss ss)
  117.   )
  118.   (vla-EndUndoMark acdoc)
  119.   (princ)
  120. ); c:r2pl

发表于 2017-10-12 14:28:04 | 显示全部楼层
楼主在测绘板块分享了很多优秀的插件,非常感谢~~
 楼主| 发表于 2018-4-25 22:08:20 | 显示全部楼层
  1. ;,转载  面域转换为轻量多段线,放大聊天窗口就整齐好看些。!
  2. (defun c:Reg>Lw        (/ en RegCentroid lw)
  3.   (if (setq en (car (entsel "\n请选择面域对象:"))) ;选择面域
  4.     (if        (= "REGION" (cdr (assoc 0 (entget en))))
  5.       (progn
  6.         (setq RegCentroid
  7.                (vlax-safearray->list
  8.                  (vlax-variant-value
  9.                    (vla-get-Centroid (vlax-ename->vla-object en))
  10.                  )
  11.                )
  12.         )                                ;面域中心        
  13.                                         ;如果只是生成多线段,就只需要(bpoly RegCentroid)一句就行了。
  14.                                         ;因为是转换,所以删除选择的面域,并返回轻量多线段
  15.         (setq LW (bpoly RegCentroid))
  16.         (entdel en)
  17.         lw
  18.       )
  19.       (progn
  20.         (princ "\n选择对象不是'面域'")
  21.         (princ)                                ;不是面域返回nil
  22.       )
  23.     )
  24.   )
  25. )
 楼主| 发表于 2018-4-25 22:16:55 | 显示全部楼层
收藏
  1. ;纯转换函数
  2. (defun reg>lw (en / lw)
  3.   (if (= 'ename (type en))
  4.     (setq en (vlax-ename->vla-object en))
  5.   )
  6.   (if (= "AcDbRegion" (vla-get-objectname en))
  7.     (setq lw (bpoly (vlax-safearray->list
  8.                       (vlax-variant-value
  9.                         (vla-get-Centroid (vlax-ename->vla-object en))
  10.                       )
  11.                     )
  12.              )
  13.     )
  14.   )
  15.   (if lw
  16.     (if        (= 'ename (type en))
  17.       lw
  18.       (vlax-ename->vla-object lw)
  19.     )
  20.   )
  21. )
发表于 2022-6-7 14:59:28 | 显示全部楼层
研究研究 谢谢谢
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-11-6 05:07 , Processed in 0.181173 second(s), 25 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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