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