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

树櫴希德 · 发表于 2016-10-22 16:47:56

本帖最后由树櫴希德于 2016-10-27 21:25 编辑

根据两期间三角网画开挖零界线-没有成功用了院长 73哥生无可恋等大侠的函数谁能改到能用？纯属研究好玩

<blockquote>(defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点

skg123 · 发表于 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

;;;by Gu_xl
(defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数)
(setvar "CMDECHO" 0)
(command "layer" "m" "bgGCD" "c" "7" "" "L" "CONTINUOUS" "" "")
(if height
(setq height (rtos height 2 3));3为高程注记位数
(setq height "")
)
(regapp "SOUTH")
;;;检查字体 "HZ" 是否存在
(if (not (tblobjname "style" "HZ"))
(command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "")
)
;;;检查是否存在高程点图块定义
(if (not (tblobjname "block" "GC200"))
(progn
(setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200"))
(setq obj
(vla-AddPolyline
blkdef
(vlax-make-variant
(vlax-safearray-fill
(vlax-make-safearray vlax-vbdouble (cons 0 5))
'(-0.2 0 0 0.2 0 0)
)
)
)
)
(vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1)
(vla-put-Closed obj :vlax-true)
(vla-put-ConstantWidth obj 0.4)
)
)
;;;插入块
(entmake (list
'(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
'(66 . 1);;;属性跟随标志,1跟随，0不跟随
(cons 2 "GC200")
(cons 10 inspt)
(cons 41 scale)
(cons 42 scale)
(cons 43 scale)
(list -3 '("SOUTH" (1000 . "202101")))
)
)
;;;插入属性
(entmake (list
'(0 . "ATTRIB")
'(100 . "AcDbEntity")
'(100 . "AcDbText")
(cons 10 (setq pt (polar inspt 0 (* 1.2 scale))))
(cons 40 (* 2.0 scale))
(cons 50 0)
(cons 41 0.8)
(cons 51 0)
(cons 1 height)
(cons 7 "HZ")
(cons 62 3)
(cons 72 0)
(cons 11 pt)
'(100 . "AcDbAttribute")
(cons 2 "height")
(cons 70 0)
(cons 74 2)
)
)
;;;结束标志
(entmake '((0 . "SEQEND")))
(princ)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;|;;===========================================================================
通用函数 ;
功能：求两个线条对象的交点 ;
适用对象: Line、Circle、Arc、Ellipse、Polyline、 ;
LWPolyline、3dPolyline、Spline ;
参数：OBJ1 ----对象1 ;
OBJ2 ----对象2 ;
Extend ----延伸选项 ;
0 acExtendNone ;
1 acExtendThisEntity ;
2 acExtendOtherEntity ;
3 acExtendBoth ;
ZZZ ----输出选项 ;
"=0" Z值取0 ;
"F1" 取第一个对象上的点 ;
"F2" 取第二个对象上的点 ;
"MAX" 取Z值大者 ;
"MIN" 取Z值小者 ;
Fuzz ----允许偏差值 ;
返回：若成功，返回点位表；否则返回nil
日期：zml84 于2007-11-05
;;|;
(vl-load-com)
(defun ZL-GETINTERS (OBJ1 OBJ2 EXTEND ZZZ FUZZ / ENT1
ENT2 PT10 PT11 PT20 PT21 OBJ11 OBJ22
ARRAY LST LST_PT I PT PT1 PT2
Z1 Z2
)
;;0、对参数的格式化处理
(if (and (= (type EXTEND) 'INT)
(<= 0 EXTEND 3)
)
()
(setq EXTEND 0)
)
(setq ZZZ (strcase ZZZ))
;;======================
;;1、获取交点集合>>>>>>>
(if (and (= (vla-get-objectname OBJ1) "AcDbLine")
(= (vla-get-objectname OBJ2) "AcDbLine")
)
;;对直线对象(line) 特别处理
(progn
(setq ENT1 (entget (vlax-vla-object->ename OBJ1))
ENT2 (entget (vlax-vla-object->ename OBJ2))
)
(setq PT10 (assoc 10 ENT1)
PT11 (assoc 11 ENT1)
PT20 (assoc 10 ENT2)
PT21 (assoc 11 ENT2)
)
;;去除Z坐标
(setq PT10 (list (cadr PT10) (caddr PT10))
PT11 (list (cadr PT11) (caddr PT11))
PT20 (list (cadr PT20) (caddr PT20))
PT21 (list (cadr PT21) (caddr PT21))
)
(setq LST (inters PT10 PT11 PT20 PT21 t))
(if LST
(setq LST (append LST '(0)))
)
)
(progn
;;=====================
;;复制实体
(setq OBJ11 (vla-copy OBJ1)
OBJ22 (vla-copy OBJ2)
)
;;向xy平面投影，将Z坐标改为0
(TOXY OBJ11)
(TOXY OBJ22)
;;获取交点集合
(setq ARRAY (vla-intersectwith OBJ11 OBJ22 EXTEND))
;;删除复制后的对象
(vla-delete OBJ11)
(vla-delete OBJ22)
;;由数组转换为表
(if (and ARRAY
(> (vlax-safearray-get-u-bound
(vlax-variant-value ARRAY)
1
)
1
)
)
(progn
(setq LST (vlax-safearray->list
(vlax-variant-value ARRAY)
)
)
)
)
)
)
;;======================
;;2、分析整理>>>>>>>
(setq LST_PT '())
(if LST
(progn
(setq I 0)
(repeat (/ (length LST) 3)
;;2.1 获取当前点位
(setq PT (list (nth I LST)
(nth (+ 1 I) LST)
(nth (+ 2 I) LST)
)
)
;;2.2 获取对象上对应点位
(setq PT1 (vlax-curve-getclosestpointtoprojection
OBJ1
PT
'(0 0 1)
)
PT2 (vlax-curve-getclosestpointtoprojection
OBJ2
PT
'(0 0 1)
)
)
(setq Z1 (caddr PT1)
Z2 (caddr PT2)
)
;;2.3 效验偏差值
;;就是说：过滤:参数中有偏差值选项，却不满足要求的点位
(if (and FUZZ
(or (= (type FUZZ) 'REAL)
(= (type FUZZ) 'INT)
)
(not (equal Z1 Z2 FUZZ))
)
;; 空处理
()
;;2.4 对输出选项的处理
(progn
(cond
((= ZZZ "F1")
(setq PT PT1)
)
((= ZZZ "F2")
(setq PT PT2)
)
((= ZZZ "MAX")
(if (> Z1 Z2)
(setq PT PT1)
(setq PT PT2)
)
)
((= ZZZ "MIN")
(if (< Z1 Z2)
(setq PT PT1)
(setq PT PT2)
)
)
(t
(setq PT PT)
)
) ;_结束cond
(if (member PT LST_PT)
()
(setq LST_PT (cons PT LST_PT))
)
) ;_结束progn
) ;_结束if
(setq I (+ I 3))
) ;_结束repeat
) ;_结束progn
) ;_结束if
;;3、返回结果>>>>>
LST_PT
) ;_结束defun
;;;============================================================
;;;功能：曲线实体上每个控制点的z坐标值置为0.0
(defun TOXY (OBJ / NAME PT1 TP2)
;;取得实体的类型名称
(setq NAME (vla-get-objectname OBJ))
(cond
;;类型1
;;直线(line)
((= NAME "AcDbLine")
;;取得直线的起终点坐标
(setq PT1 (vlax-variant-value (vla-get-startpoint OBJ))
PT2 (vlax-variant-value (vla-get-endpoint OBJ))
)
;;改变z值为0.0
(vlax-safearray-put-element PT1 2 0.0)
(vlax-safearray-put-element PT2 2 0.0)
(vla-put-startpoint OBJ PT1)
(vla-put-endpoint OBJ PT2)
)
;;类型2
;;圆(circle)
;;圆弧(arc)
;;椭圆及椭圆弧(ellipse)
((or (= NAME "AcDbCircle")
(= NAME "AcDbArc")
(= NAME "AcDbEllipse")
)
;;取得中心点座标
(setq PT1 (vlax-variant-value (vla-get-center OBJ)))
;;改变中心点座标z值为0.0
(vlax-safearray-put-element PT1 2 0.0)
(vla-put-center OBJ PT1)
)
;;类型3
;;多段线(polyline、lwpolyline)
;;拟合的2维多段线(polyline、lwpolyline)
((or (= NAME "AcDbPolyline")
(= NAME "AcDb2dPolyline")
)
;;改变标高值为0.0
(vla-put-elevation OBJ 0.0)
)
;;类型4
;;三维多段线(3dpolyline)
((= NAME "AcDb3dPolyline")
;;取得3维多段线的控制点
(setq PT1 (vlax-variant-value (vla-get-coordinates OBJ))
I 0
)
(repeat (/ (length (vlax-safearray->list PT1)) 3)
(vlax-safearray-put-element PT1 (+ I 2) 0.0)
(setq I (+ I 3))
)
(vla-put-coordinates OBJ PT1)
)
;;类型5
;;样条曲线(Spline)
((= NAME "AcDbSpline")
;;取得样条曲线的拟合点
;;改变每个拟合点的z值为0.0
(setq PT1 (vlax-variant-value (vla-get-fitpoints OBJ))
I 0
)
(repeat (vla-get-numberoffitpoints OBJ)
(vlax-safearray-put-element PT1 (+ I 2) 0.0)
(setq I (+ I 3))
)
(vla-put-fitpoints OBJ PT1)
;;取得样条曲线的控制点
;;改变每个控制点的z值为0.0
(setq
PT2 (vlax-variant-value (vla-get-controlpoints OBJ))
I 0
)
(repeat (vla-get-numberofcontrolpoints OBJ)
(vlax-safearray-put-element PT2 (+ I 2) 0.0)
(setq I (+ I 3))
)
(vla-put-controlpoints OBJ PT2)
)
(t NIL)
)
) ;_结束defun
;(setq ppzzxx (ZL-GETINTERS (vlax-ename->vla-object(car (entsel) ) ) (vlax-ename->vla-object(car (entsel) ) ) 0 "f2" nil) )
;选择集与对象名表互转
(defun cx-ss2en
(ss / enlst)
(cond
((= (type ss) 'PICKSET)
(vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS)))
)
((= (type ss) 'LIST)
(setq enlst (ssadd))
(last (mapcar '(lambda (x) (ssadd x enlst)) ss))
)
((='ename(type ss))
(ssadd ss)
)
)
);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点
(setq a(vlax-ename->vla-object e)
q(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates a)))
m(vla-get-objectname a)a 0
m(if(= m"AcDb3dPolyline")3 2))
(repeat(/(length q)m)
(cond((= m 2)(setq p1(list(nth a q)(nth(+ a 1)q))))
((= m 3)(setq p1(list(nth a q)(nth(+ a 1)q)(nth(+ a 2)q)))))
(setq p(if (member p1 p)p (append p(list p1)))
a(+ a m)))
p)
(defun xyp-Pline (lst / lst pt)
(entmake (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst))'(70 . 129))
(mapcar '(lambda (pt)(cons 10 pt)) lst ))
) (vl-cmdf "_.region" (entlast) "") (entlast)
)
(defun xyp-get-Inters (s1 s2 / s1 s2 s3)
(vl-cmdf "_.intersect" s1 s2 "") ;
(if (equal (cdr(cadr(entget(entlast) ))) "REGION") (setq s3 (entlast)) (setq s3 nil))
s3
)
(defun xyp-erase (lst / lst)
(foreach n lst
(entdel n))
)
;;;;;;;;;;;;;;;;;;;;;;
(defun rtp ( en / ss n k en spg)
(setvar "cmdecho" 0)
(command "layer" "n" "PG" "c" "6" "PG" "s" "PG" "")
(command "layer" "n" "PG1" "c" "7" "PG1" "s" "PG1" "")
(command "peditaccept" 1)
(command "chprop" en "" "la" "PG1" "")
(command "explode" en)
(setq spg (ssget "X" '((8 . "PG1"))))
(command "pedit" "m" spg "" "j" "0" "")
(setq spg (ssget "X" '((8 . "PG1"))))
(command "chprop" spg "" "la" "PG" "")
(command "peditaccept" 0)
(command "layer" "s" "PG" "")
(command "purge" "la" "" "no")
(setvar "cmdecho" 1)
(entlast)
)
;;;;;;;;;;;;;;;;;;;;;;;
(defun REGIONlist(en / pt x-pt y-pt pt1 en1 en1get 10list )
;(setq en(car(entsel)))
(setq pt(vla-get-Centroid (vlax-ename->vla-object en)))
(setq x-pt (vlax-safearray-get-element (vlax-variant-value pt) 0))
(setq y-pt (vlax-safearray-get-element (vlax-variant-value pt) 1))
(setq pt1(list x-pt y-pt 0.0))
(command "BOUNDARY" pt1 "")
(vla-delete(vlax-ename->vla-object en) )
(setq en1(entlast))
(setq en1get(entget en1))
(setq 10list nil)
(foreach n en1get(if (= 10 (car n))
(setq 10list(cons (cdr n) 10list ))))
(vla-delete(vlax-ename->vla-object en1) ) ;(entdel en1)
10list
)
;; xyp-IntersWith2Ptn 两点表连线的交点表 (xyp-IntersWith2Ptn ptn1 ptn2)
(defun MJD (ptn1 ptn2 / s1 s2 ptn11 ptn pzx)
(setq s1 (xyp-Pline ptn1 )
s2 (xyp-Pline ptn2 )
ptn11 (xyp-get-Inters s1 s2 )
ptn (REGIONlist ptn11)
)
(xyp-erase (list s1 s2))
(vla-delete(vlax-ename->vla-object ptn11) )
ptn
)
(defun PoInPl(pt p / n i va ang);;该过程由 StEf 44604813提供，本人只是把输出由原来的t,nil改为了-1,0,1
(setq n(length pt)
pt(append pt(list(car pt)))i 0 ang 0)
(while(< i n)
(setq va(-(angle p(nth i pt))(angle p(nth(1+ i)pt))))
(if (<(abs(-(abs va)pi))0.000001)(setq ang 2 i n)
(progn(cond((> va pi)(setq va (- va pi)))
((< va (* -1 pi))(setq va (+ va pi))))
(setq ang(+ ang va)i(1+ i)))))
(if(= ang 2)0
(if(<(abs(-(abs ang) pi))0.000001)1 -1))
);defun
;;;改改更贱康
(defun temp (pa pb p0 p1 p2 / MAT:vxv {vp} {v} a b)
(defun MAT:vxv (u v)
(list
(- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
(- (* (car v) (caddr u)) (* (car u) (caddr v)))
(- (* (car u) (cadr v)) (* (car v) (cadr u)))
)
)
(setq {vp} (MAT:vxv (mapcar '- p1 p0) (mapcar '- p2 p0)))
(setq {v} (mapcar '- pa pb))
(setq a (apply '+
(mapcar '(lambda (n m vp) (* (- n m) vp)) p0 pa {vp})
)
)
(setq b (apply '+ (mapcar '* {vp} {v})))
(if (equal b 0.0 1e-6)
nil
(mapcar '(lambda (m v) (+ m (* v (/ a b)))) pa {v})
)
)
;(setq ptlist (plinexy(car(entsel))) )
;(setq p1 (getpoint "\n请选择第一点：" ))
;(setq p2 (getpoint "\n请选择第2点：" ))
;(setq pzx (temp p1 p2 (car ptlist) (cadr ptlist)(caddr ptlist)) )
;(entmake (list '(0 . "polyline") (cons 10 p1) (cons 10 p2) (cons 10 pzx)))
;(command "_.3dpoly" p1 pzx p2 "")
;(setq opo '((100 200 10)(10 20 11)(23 25 6)))
;(mapcar '(lambda (x ) (vl-remove (last x)x) )opo)
(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)
(setvar "osmode" 16384)
(setq ssa (ssget '((0 . "POLYLINE") (8 . "sjw"))))
(setq ssb (ssget '((0 . "POLYLINE") (8 . "sjw1"))))
(setq ii 0
no 0
)
(setq blc (getint "\n请输入比例尺1:<500>"))
(if (= blc nil)(setq blc 500))
(setvar 'userr1 blc);设置比例尺
(setq scale (* 0.001 blc));缩放比例
(mapcar '(lambda (x)
;;;;=====
(setq pzx (plinexy x))
(foreach n (cx-ss2en ssb)
(setq pzx1 (plinexy n))
(if (or (/= (ZL-GETINTERS (vlax-ename->vla-object x) (vlax-ename->vla-object n ) 0 "f2" nil) nil)
(and (>= (poinpl (mapcar '(lambda (b) (vl-remove (last b)b) )pzx) (vl-remove (last (car pzx1)) (car pzx1)) )0)
(>= (poinpl (mapcar '(lambda (b) (vl-remove (last b)b) )pzx) (vl-remove (last (cadr pzx1)) (cadr pzx1)) )0)
(>= (poinpl (mapcar '(lambda (b) (vl-remove (last b)b) )pzx) (vl-remove (last (caddr pzx1)) (caddr pzx1)) )0)
)
(and (>= (poinpl (mapcar '(lambda (b) (vl-remove (last b)b) )pzx1) (vl-remove (last (car pzx)) (car pzx)) )0)
(>= (poinpl (mapcar '(lambda (b) (vl-remove (last b)b) )pzx1) (vl-remove (last (cadr pzx)) (cadr pzx)) )0)
(>= (poinpl (mapcar '(lambda (b) (vl-remove (last b)b) )pzx1) (vl-remove (last (caddr pzx)) (caddr pzx)) )0)
)
)
(progn
(setq a1 (temp (car pzx1)(cadr pzx1) (car pzx) (cadr pzx) (caddr pzx) ))
(setq a2 (temp (car pzx1)(caddr pzx1) (car pzx) (cadr pzx) (caddr pzx) ))
(setq a3 (temp (caddr pzx1)(cadr pzx1) (car pzx) (cadr pzx) (caddr pzx) ))
(setq a4 (temp (car pzx)(cadr pzx) (car pzx1) (cadr pzx1) (caddr pzx1) ))
(setq a5 (temp (car pzx)(caddr pzx) (car pzx1) (cadr pzx1) (caddr pzx1) ))
(setq a6 (temp (caddr pzx)(cadr pzx) (car pzx1) (cadr pzx1) (caddr pzx1) ))
;(print x) (print n)
(setq ppp (MJD(mapcar '(lambda (b) (vl-remove (last b)b) )pzx)(mapcar '(lambda (h) (vl-remove (last h)h) )pzx1) ) )
;(print a1) (print a2)(print a3)(print a4)(print a5)(print a6)
;(PRINT PPP)
;(command "_.3dpoly" a1 a2 a3 a4 a5 a6 "")
(SETQ PPPP (vl-remove 'nil (LIST a1 a2 a3 a4 a5 a6))) ;(xyp-pline (mapcar '(lambda (h) (vl-remove (last h)h) )pppp))
(SETQ PPPPP '())(SETQ I 0)
(REPEAT (LENGTH PPPP)
(setq ooxx (nth i pppp))
(if (and (/= ooxx nil)
(>= (poinpl ppp (vl-remove (last ooxx)ooxx) )0)) (setq ppppp (append ppppp (list ooxx) )) )
(SETQ I (1+ I))
) (print ppppp) (xyp-pline (mapcar '(lambda (b) (vl-remove (last b)b) )ppppp))
(mapcar '(lambda (m) (gxl-cs:gcd m (last m) scale) )ppppp)
)
)
);;;;======
)
(cx-ss2en ssa)
)
(princ)
)

;;;by Gu_xl 
(defun gxl-cs:gcd (inspt height scale / pt blkdef obj);展高程点函数(inspt:插入点,heitht:高程值,scale:缩放比例,xsws:高程注记位数) 
  (setvar "CMDECHO" 0) 
  (command "layer" "m" "bgGCD" "c" "7" "" "L" "CONTINUOUS" ""  "") 
  (if height 
    (setq height (rtos height 2 3));3为高程注记位数 
    (setq height "") 
  ) 
  (regapp "SOUTH") 
   
  ;;;检查字体 "HZ" 是否存在 
  (if (not (tblobjname "style" "HZ")) 
    (command "style" "HZ" "rs.shx,hztxt.shx" 0 1 0 "" "" "") 
  ) 
  ;;;检查是否存在高程点图块定义 
  (if (not (tblobjname "block" "GC200")) 
    (progn 
      (setq blkdef (vla-Add (vla-get-Blocks (vla-get-ActiveDocument (vlax-get-acad-object))) (vlax-3D-point '(0 0 0)) "GC200")) 
      (setq obj 
        (vla-AddPolyline 
           blkdef 
           (vlax-make-variant 
              (vlax-safearray-fill 
                 (vlax-make-safearray vlax-vbdouble (cons 0 5)) 
                 '(-0.2 0 0 0.2 0 0) 
              ) 
           ) 
        ) 
      ) 
      (vla-SetBulge obj 0 1) (vla-SetBulge obj 1 1) 
      (vla-put-Closed obj :vlax-true) 
      (vla-put-ConstantWidth obj 0.4) 
    ) 
  ) 
  ;;;插入块 
  (entmake (list 
             '(0 . "INSERT") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbBlockReference") 
             '(66 . 1);;;属性跟随标志,1跟随，0不跟随 
              (cons 2 "GC200") 
              (cons 10 inspt) 
              (cons 41 scale) 
              (cons 42 scale) 
              (cons 43 scale) 
              (list -3 '("SOUTH" (1000 . "202101"))) 
           ) 
  ) 
  ;;;插入属性 
  (entmake (list 
             '(0 . "ATTRIB") 
             '(100 . "AcDbEntity") 
             '(100 . "AcDbText") 
              (cons 10 (setq pt (polar inspt 0 (* 1.2 scale)))) 
              (cons 40 (* 2.0 scale)) 
              (cons 50 0) 
              (cons 41 0.8) 
              (cons 51 0) 
              (cons 1 height) 
              (cons 7 "HZ") 
       (cons 62 3) 
              (cons 72 0) 
              (cons 11 pt) 
              '(100 . "AcDbAttribute") 
              (cons 2 "height") 
              (cons 70  0) 
              (cons 74 2) 
           ) 
   ) 
   ;;;结束标志 
   (entmake '((0 . "SEQEND"))) 
   (princ) 
) 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 
 
 
;|;;=========================================================================== 
      通用函数                                                                ; 
功能：求两个线条对象的交点                                                    ; 
      适用对象: Line、Circle、Arc、Ellipse、Polyline、                        ; 
      LWPolyline、3dPolyline、Spline                                          ; 
参数：OBJ1   ----对象1                                                        ; 
      OBJ2   ----对象2                                                        ; 
      Extend ----延伸选项                                                     ; 
                 0  acExtendNone                                              ; 
                 1  acExtendThisEntity                                        ; 
                 2  acExtendOtherEntity                                       ; 
                 3  acExtendBoth                                              ; 
      ZZZ    ----输出选项                                                     ; 
                 "=0"  Z值取0                                                 ; 
                 "F1"  取第一个对象上的点                                     ; 
                 "F2"  取第二个对象上的点                                     ; 
                 "MAX" 取Z值大者                                              ; 
                 "MIN" 取Z值小者                                              ; 
      Fuzz   ----允许偏差值                                                   ; 
返回：若成功，返回点位表；否则返回nil 
日期：zml84 于2007-11-05 
;;|; 
(vl-load-com) 
(defun ZL-GETINTERS (OBJ1   OBJ2   EXTEND ZZZ  FUZZ /      ENT1 
       ENT2   PT10   PT11   PT20  PT21 OBJ11  OBJ22 
       ARRAY  LST    LST_PT I  PT PT1    PT2 
       Z1     Z2 
      ) 
    ;;0、对参数的格式化处理 
    (if (and (= (type EXTEND) 'INT) 
      (<= 0 EXTEND 3) 
 ) 
 () 
 (setq EXTEND 0) 
    ) 
    (setq ZZZ (strcase ZZZ)) 
    ;;====================== 
    ;;1、获取交点集合>>>>>>> 
    (if (and (= (vla-get-objectname OBJ1) "AcDbLine") 
      (= (vla-get-objectname OBJ2) "AcDbLine") 
 ) 
 ;;对直线对象(line) 特别处理 
 (progn 
     (setq ENT1 (entget (vlax-vla-object->ename OBJ1)) 
    ENT2 (entget (vlax-vla-object->ename OBJ2)) 
     ) 
     (setq PT10 (assoc 10 ENT1) 
    PT11 (assoc 11 ENT1) 
    PT20 (assoc 10 ENT2) 
    PT21 (assoc 11 ENT2) 
     ) 
     ;;去除Z坐标 
     (setq PT10 (list (cadr PT10) (caddr PT10)) 
    PT11 (list (cadr PT11) (caddr PT11)) 
    PT20 (list (cadr PT20) (caddr PT20)) 
    PT21 (list (cadr PT21) (caddr PT21)) 
     ) 
     (setq LST (inters PT10 PT11 PT20 PT21 t)) 
     (if LST 
  (setq LST (append LST '(0))) 
     ) 
 ) 
 (progn 
     ;;===================== 
     ;;复制实体 
     (setq OBJ11 (vla-copy OBJ1) 
    OBJ22 (vla-copy OBJ2) 
     ) 
     ;;向xy平面投影，将Z坐标改为0 
     (TOXY OBJ11) 
     (TOXY OBJ22) 
     ;;获取交点集合 
     (setq ARRAY (vla-intersectwith OBJ11 OBJ22 EXTEND)) 
     ;;删除复制后的对象 
     (vla-delete OBJ11) 
     (vla-delete OBJ22) 
     ;;由数组转换为表 
     (if (and ARRAY 
       (> (vlax-safearray-get-u-bound 
       (vlax-variant-value ARRAY) 
       1 
   ) 
   1 
       ) 
  ) 
  (progn 
      (setq LST (vlax-safearray->list 
      (vlax-variant-value ARRAY) 
         ) 
      ) 
  ) 
     ) 
 ) 
    ) 
    ;;====================== 
    ;;2、分析整理>>>>>>> 
    (setq LST_PT '()) 
    (if LST 
 (progn 
     (setq I 0) 
     (repeat (/ (length LST) 3) 
  ;;2.1 获取当前点位 
  (setq PT (list (nth I LST) 
          (nth (+ 1 I) LST) 
          (nth (+ 2 I) LST) 
    ) 
  ) 
  ;;2.2 获取对象上对应点位 
  (setq PT1 (vlax-curve-getclosestpointtoprojection 
         OBJ1 
         PT 
         '(0 0 1) 
     ) 
        PT2 (vlax-curve-getclosestpointtoprojection 
         OBJ2 
         PT 
         '(0 0 1) 
     ) 
  ) 
  (setq Z1 (caddr PT1) 
        Z2 (caddr PT2) 
  ) 
 
  ;;2.3 效验偏差值 
  ;;就是说：过滤:参数中有偏差值选项，却不满足要求的点位 
  (if (and FUZZ 
    (or (= (type FUZZ) 'REAL) 
        (= (type FUZZ) 'INT) 
    ) 
    (not (equal Z1 Z2 FUZZ)) 
      ) 
      ;; 空处理 
      () 
      ;;2.4 对输出选项的处理 
      (progn 
   (cond 
       ((= ZZZ "F1") 
        (setq PT PT1) 
       ) 
       ((= ZZZ "F2") 
        (setq PT PT2) 
       ) 
       ((= ZZZ "MAX") 
        (if (> Z1 Z2) 
     (setq PT PT1) 
     (setq PT PT2) 
        ) 
       ) 
       ((= ZZZ "MIN") 
        (if (< Z1 Z2) 
     (setq PT PT1) 
     (setq PT PT2) 
        ) 
       ) 
       (t 
        (setq PT PT) 
       ) 
   ) ;_结束cond 
   (if (member PT LST_PT) 
       () 
       (setq LST_PT (cons PT LST_PT)) 
   ) 
      ) ;_结束progn 
  ) ;_结束if 
  (setq I (+ I 3)) 
     ) ;_结束repeat 
 ) ;_结束progn 
    ) ;_结束if 
    ;;3、返回结果>>>>> 
    LST_PT 
) ;_结束defun 
;;;============================================================ 
;;;功能：曲线实体上每个控制点的z坐标值置为0.0                   
(defun TOXY (OBJ / NAME PT1 TP2) 
    ;;取得实体的类型名称 
    (setq NAME (vla-get-objectname OBJ)) 
    (cond 
 ;;类型1 
 ;;直线(line) 
 ((= NAME "AcDbLine") 
  ;;取得直线的起终点坐标 
  (setq PT1 (vlax-variant-value (vla-get-startpoint OBJ)) 
        PT2 (vlax-variant-value (vla-get-endpoint OBJ)) 
  ) 
  ;;改变z值为0.0 
  (vlax-safearray-put-element PT1 2 0.0) 
  (vlax-safearray-put-element PT2 2 0.0) 
  (vla-put-startpoint OBJ PT1) 
  (vla-put-endpoint OBJ PT2) 
 ) 
 ;;类型2 
 ;;圆(circle) 
 ;;圆弧(arc) 
 ;;椭圆及椭圆弧(ellipse) 
 ((or (= NAME "AcDbCircle") 
      (= NAME "AcDbArc") 
      (= NAME "AcDbEllipse") 
  ) 
  ;;取得中心点座标 
  (setq PT1 (vlax-variant-value (vla-get-center OBJ))) 
  ;;改变中心点座标z值为0.0 
  (vlax-safearray-put-element PT1 2 0.0) 
  (vla-put-center OBJ PT1) 
 ) 
 ;;类型3 
 ;;多段线(polyline、lwpolyline) 
 ;;拟合的2维多段线(polyline、lwpolyline) 
 ((or (= NAME "AcDbPolyline") 
      (= NAME "AcDb2dPolyline") 
  ) 
  ;;改变标高值为0.0 
  (vla-put-elevation OBJ 0.0) 
 ) 
 ;;类型4 
 ;;三维多段线(3dpolyline)   
 ((= NAME "AcDb3dPolyline") 
  ;;取得3维多段线的控制点 
  (setq PT1 (vlax-variant-value (vla-get-coordinates OBJ)) 
        I   0 
  ) 
  (repeat (/ (length (vlax-safearray->list PT1)) 3) 
      (vlax-safearray-put-element PT1 (+ I 2) 0.0) 
      (setq I (+ I 3)) 
  ) 
  (vla-put-coordinates OBJ PT1) 
 ) 
 ;;类型5 
 ;;样条曲线(Spline) 
 ((= NAME "AcDbSpline") 
  ;;取得样条曲线的拟合点 
  ;;改变每个拟合点的z值为0.0 
  (setq PT1 (vlax-variant-value (vla-get-fitpoints OBJ)) 
        I   0 
  ) 
  (repeat (vla-get-numberoffitpoints OBJ) 
      (vlax-safearray-put-element PT1 (+ I 2) 0.0) 
      (setq I (+ I 3)) 
  ) 
  (vla-put-fitpoints OBJ PT1) 
  ;;取得样条曲线的控制点 
  ;;改变每个控制点的z值为0.0   
  (setq 
      PT2 (vlax-variant-value (vla-get-controlpoints OBJ)) 
      I  0 
  ) 
  (repeat (vla-get-numberofcontrolpoints OBJ) 
      (vlax-safearray-put-element PT2 (+ I 2) 0.0) 
      (setq I (+ I 3)) 
  ) 
  (vla-put-controlpoints OBJ PT2) 
 ) 
 (t NIL) 
    ) 
) ;_结束defun 
;(setq ppzzxx (ZL-GETINTERS (vlax-ename->vla-object(car (entsel) ) ) (vlax-ename->vla-object(car (entsel) ) ) 0 "f2" nil)   ) 
 ;选择集与对象名表互转 
(defun cx-ss2en 
  (ss / enlst) 
  (cond 
    ((= (type ss) 'PICKSET) 
      (vl-remove-if-not '(lambda (x) (= (type x) 'ENAME)) (mapcar 'cadr (ssnamex SS))) 
    ) 
    ((= (type ss) 'LIST) 
      (setq enlst (ssadd)) 
      (last (mapcar '(lambda (x) (ssadd x enlst)) ss)) 
    ) 
    ((='ename(type ss)) 
      (ssadd ss) 
    ) 
  ) 
);;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 
 
(defun plinexy(e / a q m p);;;LWPolyline,POLYLINE顶点,去掉完全重合点 
    (setq a(vlax-ename->vla-object e) 
  q(vlax-safearray->list(vlax-variant-value(vla-get-Coordinates a))) 
    m(vla-get-objectname a)a 0 
    m(if(= m"AcDb3dPolyline")3 2)) 
    (repeat(/(length q)m) 
      (cond((= m 2)(setq p1(list(nth a q)(nth(+ a 1)q)))) 
     ((= m 3)(setq p1(list(nth a q)(nth(+ a 1)q)(nth(+ a 2)q))))) 
      (setq p(if (member p1 p)p (append p(list p1))) 
      a(+ a m))) 
    p) 
 
(defun xyp-Pline (lst / lst pt) 
 (entmake (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (length lst))'(70 . 129)) 
      (mapcar '(lambda (pt)(cons 10 pt)) lst )) 
  ) (vl-cmdf "_.region" (entlast) "") (entlast) 
) 
 
(defun xyp-get-Inters (s1 s2 / s1 s2 s3) 
  (vl-cmdf "_.intersect" s1 s2 "") ; 
(if (equal (cdr(cadr(entget(entlast) ))) "REGION") (setq s3 (entlast))  (setq s3 nil)) 
  s3 
  ) 
(defun xyp-erase (lst / lst) 
  (foreach n lst 
     (entdel n)) 
  ) 
;;;;;;;;;;;;;;;;;;;;;; 
(defun rtp ( en / ss n k en spg) 
  (setvar "cmdecho" 0) 
 
  (command "layer" "n" "PG" "c" "6" "PG" "s" "PG" "") 
  (command "layer" "n" "PG1" "c" "7" "PG1" "s" "PG1" "") 
  (command "peditaccept" 1) 
   
    
    (command "chprop" en "" "la" "PG1" "") 
    (command "explode" en) 
    (setq spg (ssget "X" '((8 . "PG1")))) 
    (command "pedit" "m" spg "" "j" "0" "") 
    (setq spg (ssget "X" '((8 . "PG1")))) 
    (command "chprop" spg "" "la" "PG" "") 
    
   
  (command "peditaccept" 0) 
  (command "layer" "s" "PG" "") 
  (command "purge" "la" "" "no") 
  (setvar "cmdecho" 1) 
  (entlast) 
) 
;;;;;;;;;;;;;;;;;;;;;;; 
(defun REGIONlist(en / pt x-pt y-pt pt1 en1 en1get 10list  ) 
;(setq en(car(entsel))) 
(setq pt(vla-get-Centroid (vlax-ename->vla-object en))) 
(setq x-pt (vlax-safearray-get-element (vlax-variant-value pt) 0)) 
(setq y-pt (vlax-safearray-get-element (vlax-variant-value pt) 1)) 
(setq pt1(list x-pt y-pt 0.0)) 
(command "BOUNDARY"  pt1 "") 
  (vla-delete(vlax-ename->vla-object en) ) 
(setq en1(entlast)) 
(setq en1get(entget en1)) 
(setq 10list nil) 
(foreach n en1get(if (= 10 (car n)) 
          (setq 10list(cons (cdr n) 10list )))) 
 (vla-delete(vlax-ename->vla-object en1) ) ;(entdel en1) 
  10list 
  ) 
;; xyp-IntersWith2Ptn 两点表连线的交点表 (xyp-IntersWith2Ptn ptn1 ptn2) 
(defun MJD (ptn1 ptn2 / s1 s2 ptn11 ptn pzx) 
  (setq  s1  (xyp-Pline ptn1 ) 
  s2  (xyp-Pline ptn2 ) 
  ptn11 (xyp-get-Inters s1 s2 ) 
  ptn  (REGIONlist ptn11) 
  ) 
  (xyp-erase (list s1 s2)) 
   
  (vla-delete(vlax-ename->vla-object ptn11) ) 
  ptn 
) 
 
 
(defun PoInPl(pt p / n i va ang);;该过程由 StEf  44604813提供，本人只是把输出由原来的t,nil改为了-1,0,1 
      (setq n(length pt) 
      pt(append pt(list(car pt)))i 0 ang 0) 
      (while(
  (setq va(-(angle p(nth i pt))(angle p(nth(1+ i)pt)))) 
  (if (<(abs(-(abs va)pi))0.000001)(setq ang 2 i n) 
    (progn(cond((> va pi)(setq va (- va pi))) 
         ((< va (* -1 pi))(setq va (+ va pi)))) 
      (setq ang(+ ang va)i(1+ i))))) 
      (if(= ang 2)0 
  (if(<(abs(-(abs ang) pi))0.000001)1 -1)) 
      );defun 
;;;改改更贱康 
(defun temp (pa pb p0 p1 p2 / MAT:vxv {vp} {v} a b) 
  (defun MAT:vxv (u v) 
    (list 
      (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u))) 
      (- (* (car v) (caddr u)) (* (car u) (caddr v))) 
      (- (* (car u) (cadr v)) (* (car v) (cadr u))) 
    ) 
  ) 
  (setq {vp} (MAT:vxv (mapcar '- p1 p0) (mapcar '- p2 p0))) 
  (setq {v} (mapcar '- pa pb)) 
  (setq  a (apply '+ 
 (mapcar '(lambda (n m vp) (* (- n m) vp)) p0 pa {vp}) 
  ) 
  ) 
  (setq b (apply '+ (mapcar '* {vp} {v}))) 
  (if (equal b 0.0 1e-6) 
    nil 
    (mapcar '(lambda (m v) (+ m (* v (/ a b)))) pa {v}) 
  ) 
) 
 
 
;(setq ptlist (plinexy(car(entsel))) ) 
;(setq p1 (getpoint "\n请选择第一点：" )) 
;(setq p2 (getpoint "\n请选择第2点：" )) 
;(setq pzx (temp p1 p2  (car ptlist) (cadr ptlist)(caddr ptlist)) ) 
 
 
;(entmake (list '(0 . "polyline") (cons 10 p1) (cons 10 p2) (cons 10 pzx))) 
;(command "_.3dpoly" p1 pzx p2 "") 
;(setq opo '((100 200 10)(10 20 11)(23 25 6))) 
 
;(mapcar '(lambda (x )  (vl-remove (last x)x)  )opo)    
(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) 
  (setvar "osmode" 16384) 
 (setq ssa (ssget '((0 . "POLYLINE") (8 . "sjw")))) 
(setq ssb (ssget '((0 . "POLYLINE") (8 . "sjw1")))) 
                (setq ii   0 
                      no  0 
                  ) 
                   
(setq blc (getint "\n请输入比例尺1:<500>")) 
  (if (= blc nil)(setq blc 500)) 
  (setvar 'userr1 blc);设置比例尺 
(setq scale (* 0.001 blc));缩放比例 
 
(mapcar '(lambda (x)    
  ;;;;===== 
     (setq pzx (plinexy x)) 
   (foreach n (cx-ss2en ssb) 
     (setq pzx1 (plinexy n)) 
  (if  (or  (/=  (ZL-GETINTERS (vlax-ename->vla-object x) (vlax-ename->vla-object n ) 0 "f2" nil) nil) 
    (and (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx) (vl-remove (last (car pzx1)) (car pzx1))  )0) 
    (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx) (vl-remove (last (cadr pzx1)) (cadr pzx1))  )0) 
    (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx) (vl-remove (last (caddr pzx1)) (caddr pzx1))  )0) 
      ) 
    (and (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx1) (vl-remove (last (car pzx)) (car pzx))  )0) 
    (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx1) (vl-remove (last (cadr pzx)) (cadr pzx))  )0) 
    (>= (poinpl (mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx1) (vl-remove (last (caddr pzx)) (caddr pzx))  )0) 
      )   
   ) 
    (progn 
         (setq a1 (temp (car pzx1)(cadr pzx1) (car pzx) (cadr pzx)  (caddr pzx) )) 
    (setq a2 (temp (car pzx1)(caddr pzx1) (car pzx) (cadr pzx)  (caddr pzx) )) 
     (setq a3 (temp (caddr pzx1)(cadr pzx1) (car pzx) (cadr pzx)  (caddr pzx) )) 
      
(setq a4 (temp (car pzx)(cadr pzx) (car pzx1) (cadr pzx1)  (caddr pzx1) )) 
    (setq a5 (temp (car pzx)(caddr pzx) (car pzx1) (cadr pzx1)  (caddr pzx1) )) 
     (setq a6 (temp (caddr pzx)(cadr pzx) (car pzx1) (cadr pzx1)  (caddr pzx1) )) 
     ;(print x) (print n) 
     (setq ppp (MJD(mapcar '(lambda (b)  (vl-remove (last b)b)  )pzx)(mapcar '(lambda (h)  (vl-remove (last h)h)  )pzx1) ) ) 
       ;(print a1) (print a2)(print a3)(print a4)(print a5)(print a6) 
       ;(PRINT PPP) 
     ;(command "_.3dpoly" a1 a2 a3 a4 a5 a6 "") 
     (SETQ PPPP (vl-remove 'nil (LIST a1 a2 a3 a4 a5 a6))) ;(xyp-pline (mapcar '(lambda (h)  (vl-remove (last h)h)  )pppp)) 
     (SETQ PPPPP '())(SETQ I 0) 
      (REPEAT (LENGTH PPPP) 
  (setq ooxx (nth i pppp)) 
    (if (and (/= ooxx nil) 
    (>= (poinpl ppp (vl-remove (last ooxx)ooxx)  )0)) (setq ppppp (append ppppp (list ooxx) )) ) 
        (SETQ I (1+ I)) 
  ) (print ppppp) (xyp-pline  (mapcar '(lambda (b)  (vl-remove (last b)b)  )ppppp))    
     (mapcar '(lambda (m)  (gxl-cs:gcd m (last m) scale)  )ppppp) 
      ) 
   ) 
 
 
      
    
     );;;;======   
  ) 
(cx-ss2en ssa) 
  ) 
 
 
(princ) 
  )

树櫴希德 · 发表于 2017-10-12 11:40:29

(defun c:r2pl (/ *error* arcbugle acdoc space ss j) ;;;面域转多段线
(vl-load-com)
;;;***************************************************************;;;
(defun *error* (msg)
(if (/= msg "Function cancelled")
(princ (strcat "\nError: " msg))
)
(vla-EndUndoMark
(vla-get-ActiveDocument (vlax-get-acad-object))
)
(princ)
)
(defun arcbulge (arc)
(- 0 (/ (sin (/ (vla-get-TotalAngle arc) 4))
(cos (/ (vla-get-TotalAngle arc) 4))
))
);defun arcbulge
(defun addPL (lst / pt en)
(setq en (entmakex (append (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (/ (length lst) 2)) (cons 70 1)) lst)
))
en
);defun addPL
(defun apss (ss / en i)
(repeat (setq i (sslength ss))
(setq en (ssname ss (setq i (1- i))))
(reg2pl en)
)
);defun apss
(defun lk-list (lst / lastpt a )
(setq rlst (car lst))
(setq lastpt (caddr rlst))
(setq rlst (reverse rlst))
(setq lst (cdr lst))
(while lst
(setq a (car lst))
(cond
((equal (car a) lastpt 0.00001)
(setq rlst (cons (cadr a) rlst))
(setq lastpt (caddr a))
(setq rlst (cons lastpt rlst))
(setq lst (cdr lst))
)
((equal (caddr a) lastpt 0.00001)
(setq rlst (cons (cadr a) rlst))
(setq lastpt (car a))
(setq rlst (cons lastpt rlst))
(setq lst (cdr lst))
)
(T
(setq lst (cdr (reverse (cons a (reverse lst)))))
)
);cond
);while lst
(setq rlst (reverse (cdr rlst)))
rlst
);defun lk-list
(defun reg2pl (obj / n reg expl plst)
(if (= 'ename (type obj))
(setq obj (vlax-ename->vla-object obj))
)
(setq reg obj)
(setq expl (vlax-invoke reg 'Explode))
;;;;;;;;;;;;;;;;;;;
(if (= (vla-get-ObjectName (car expl)) "AcDbRegion")
(progn
(setq expl1 expl)
(while expl1
(reg2pl (car expl1))
(setq expl1 (cdr expl1))
)
(vla-delete obj)
)
(progn
(if (vl-every '(lambda (x)
(or
(= (vla-get-ObjectName x) "AcDbLine")
(= (vla-get-ObjectName x) "AcDbArc")
)
)
expl
)
(progn
(vla-delete reg)
(setq plst (lk-list (mapcar '(lambda (x)
(list
(cons 10 (reverse (cdr (reverse (vlax-get x 'StartPoint)))))
(if (= (vla-get-ObjectName x) "AcDbArc")
(setq blst (cons 42 (arcbulge x)))
(setq blst (cons 42 0))
)
(cons 10 (reverse (cdr (reverse (vlax-get x 'EndPoint)))))
)
)
expl
)
))
(addpl plst)
)
)
(mapcar 'vla-delete expl)
);progn
);if
);reg2pl
;;;***************************************************************;;;
(setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object))
space (if (= 1 (getvar "CVPORT"))
(vla-get-PaperSpace acdoc)
(vla-get-ModelSpace acdoc)
)
)
(vla-StartUndoMark acdoc)
(setq j 0)
(while (setq ss (ssget ":s" '((0 . "REGION"))))
(setq j (+ (sslength ss) j))
(apss ss)
)
(vla-EndUndoMark acdoc)
(princ)
); c:r2pl

(defun c:r2pl (/ *error* arcbugle acdoc space ss j) ;;;面域转多段线 
(vl-load-com) 
;;;***************************************************************;;; 
  (defun *error* (msg) 
    (if        (/= msg "Function cancelled") 
      (princ (strcat "\nError: " msg)) 
    ) 
    (vla-EndUndoMark 
      (vla-get-ActiveDocument (vlax-get-acad-object)) 
    ) 
    (princ) 
  ) 
(defun arcbulge (arc) 
    (- 0 (/ (sin (/ (vla-get-TotalAngle arc) 4)) 
       (cos (/ (vla-get-TotalAngle arc) 4)) 
    )) 
);defun arcbulge 
(defun addPL (lst / pt en) 
  (setq en (entmakex (append    (list '(0 . "LWPOLYLINE") '(100 . "AcDbEntity") '(100 . "AcDbPolyline") (cons 90 (/ (length lst) 2)) (cons 70 1)) lst) 
  )) 
  en 
);defun addPL 
(defun apss (ss / en i) 
  (repeat (setq i (sslength ss)) 
    (setq en (ssname ss (setq i (1- i)))) 
    (reg2pl en) 
  ) 
);defun apss 
(defun lk-list (lst / lastpt a ) 
  (setq rlst (car lst)) 
  (setq lastpt (caddr rlst)) 
  (setq rlst (reverse rlst)) 
  (setq lst (cdr lst)) 
  (while lst 
    (setq a (car lst)) 
        (cond 
          ((equal (car a) lastpt 0.00001) 
            (setq rlst (cons (cadr a) rlst)) 
                (setq lastpt (caddr a)) 
                (setq rlst (cons lastpt rlst)) 
                (setq lst (cdr lst)) 
          ) 
          ((equal (caddr a) lastpt 0.00001) 
            (setq rlst (cons (cadr a) rlst)) 
                (setq lastpt (car a)) 
                (setq rlst (cons lastpt rlst)) 
                (setq lst (cdr lst)) 
          ) 
          (T 
                (setq lst (cdr (reverse (cons a (reverse lst))))) 
          ) 
        );cond 
  );while lst 
  (setq rlst (reverse (cdr rlst))) 
  rlst 
);defun lk-list 
(defun reg2pl (obj / n reg expl plst) 
  (if (= 'ename (type obj)) 
    (setq obj (vlax-ename->vla-object obj)) 
  ) 
    (setq reg obj) 
        (setq expl (vlax-invoke reg 'Explode)) 
                ;;;;;;;;;;;;;;;;;;; 
    (if (= (vla-get-ObjectName (car expl)) "AcDbRegion") 
      (progn 
            (setq expl1 expl) 
                (while expl1 
                  (reg2pl (car expl1)) 
                  (setq expl1 (cdr expl1)) 
                ) 
                (vla-delete obj) 
          ) 
          (progn 
        (if (vl-every '(lambda (x) 
                         (or 
                           (= (vla-get-ObjectName x) "AcDbLine") 
                           (= (vla-get-ObjectName x) "AcDbArc") 
                         ) 
                       ) 
                      expl 
            ) 
          (progn 
            (vla-delete reg) 
            (setq plst (lk-list (mapcar '(lambda        (x) 
                                  (list         
                                        (cons 10 (reverse (cdr (reverse (vlax-get x 'StartPoint))))) 
                                                                                (if (= (vla-get-ObjectName x) "AcDbArc") 
                                          (setq blst (cons 42 (arcbulge x))) 
                                                                                  (setq blst (cons 42 0)) 
                                        ) 
                                        (cons 10 (reverse (cdr (reverse (vlax-get x 'EndPoint))))) 
                                  ) 
                                ) 
                               expl 
                       ) 
            )) 
            (addpl plst) 
          ) 
          
        ) 
                (mapcar 'vla-delete expl) 
    );progn 
  );if 
);reg2pl 
;;;***************************************************************;;; 
  (setq acdoc (vla-get-ActiveDocument (vlax-get-acad-object)) 
        space (if (= 1 (getvar "CVPORT")) 
                  (vla-get-PaperSpace acdoc) 
                  (vla-get-ModelSpace acdoc) 
               ) 
  ) 
  (vla-StartUndoMark acdoc) 
  (setq j 0) 
  (while (setq ss (ssget ":s" '((0 . "REGION")))) 
    (setq j (+ (sslength ss) j)) 
    (apss ss) 
  ) 
  (vla-EndUndoMark acdoc) 
  (princ) 
); c:r2pl

czb203 · 发表于 2017-10-12 14:28:04

楼主在测绘板块分享了很多优秀的插件，非常感谢~~

树櫴希德 · 发表于 2018-4-25 22:08:20

;，转载面域转换为轻量多段线，放大聊天窗口就整齐好看些。！
(defun c:Reg>Lw (/ en RegCentroid lw)
(if (setq en (car (entsel "\n请选择面域对象："))) ;选择面域
(if (= "REGION" (cdr (assoc 0 (entget en))))
(progn
(setq RegCentroid
(vlax-safearray->list
(vlax-variant-value
(vla-get-Centroid (vlax-ename->vla-object en))
)
)
) ;面域中心
;如果只是生成多线段，就只需要(bpoly RegCentroid)一句就行了。
;因为是转换，所以删除选择的面域，并返回轻量多线段
(setq LW (bpoly RegCentroid))
(entdel en)
lw
)
(progn
(princ "\n选择对象不是'面域'")
(princ) ;不是面域返回nil
)
)
)
)

树櫴希德 · 发表于 2018-4-25 22:16:55

;纯转换函数
(defun reg>lw (en / lw)
(if (= 'ename (type en))
(setq en (vlax-ename->vla-object en))
)
(if (= "AcDbRegion" (vla-get-objectname en))
(setq lw (bpoly (vlax-safearray->list
(vlax-variant-value
(vla-get-Centroid (vlax-ename->vla-object en))
)
)
)
)
)
(if lw
(if (= 'ename (type en))
lw
(vlax-ename->vla-object lw)
)
)
)

LIULISHENG · 发表于 2021-12-3 09:08:21

感谢分享

willing0 · 发表于 2022-6-7 14:59:28

研究研究谢谢谢

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

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

本帖子中包含更多资源

相关帖子