lisp求某一直线与多段线的交点

窗外流逝的时光 · 发表于 2016-4-27 21:01

请问各位大神，可以用lisp求某一直线与多段线的交点吗

zml84 · 发表于 2022-12-22 10:59

本帖最后由 zml84 于 2022-12-22 11:01 编辑

(vl-load-com)
;;;=================================================================*
;;; 通用函数 *
;;;功能：求两个线条对象的交点 *
;;; 适用对象: Line、Circle、Arc、Ellipse、Polyline、 *
;;; LWPolyline、3dPolyline、Spline *
;;;参数：OBJ1 ----对象1 *
;;; OBJ2 ----对象2 *
;;; Extend ----延伸选项 *
;;; 0 acExtendNone *
;;; 1 acExtendThisEntity *
;;; 2 acExtendOtherEntity *
;;; 3 acExtendBoth *
;;; ZZZ ----输出选项 *
;;; "NON" 舍去Z值，返回二维坐标 *
;;; "=0" Z值取0 *
;;; "F1" 取第一个对象上的点 *
;;; "F2" 取第二个对象上的点 *
;;; "MAX" 取Z值大者 *
;;; "MIN" 取Z值小者 *
;;; Fuzz ----允许偏差值 *
;;;返回：若成功，返回点位表；否则返回nil *
;;;日期：zml84 于2007-11-05 *
;;; *
(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 nil));_该处有弊端，需改进
(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 "NON")
(setq PT (list (car PT1) (cadr PT1)))
)
((= 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 i)
;;取得实体的类型名称
(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
;;;=================================================================*
;|;;
(defun C:TTt (/ S1 S2 OBJ1 OBJ2)
(if (and (setq S1 (entsel "\n线1: "))
(setq S2 (entsel "\n线2: "))
)
(progn
(setq OBJ1 (vlax-ename->vla-object (car S1))
OBJ2 (vlax-ename->vla-object (car S2))
)
(princ "\n0\t\t")
(princ (ZL-GETINTERS OBJ1 OBJ2 0 "Max" nil))
(princ "\n1\t\t")
(princ (ZL-GETINTERS OBJ1 OBJ2 1 "Max" nil))
(princ "\n2\t\t")
(princ (ZL-GETINTERS OBJ1 OBJ2 2 "Max" nil))
(princ "\n3\t\t")
(princ (ZL-GETINTERS OBJ1 OBJ2 3 "Max" nil))
)
)
(princ)
)
;;|;

(vl-load-com) 
;;;=================================================================* 
;;;      通用函数                                                   * 
;;;功能：求两个线条对象的交点                                       * 
;;;      适用对象: Line、Circle、Arc、Ellipse、Polyline、           * 
;;;      LWPolyline、3dPolyline、Spline                             * 
;;;参数：OBJ1   ----对象1                                           * 
;;;      OBJ2   ----对象2                                           * 
;;;      Extend ----延伸选项                                        * 
;;;                 0  acExtendNone                                 * 
;;;                 1  acExtendThisEntity                           * 
;;;                 2  acExtendOtherEntity                          * 
;;;                 3  acExtendBoth                                 * 
;;;      ZZZ    ----输出选项                                        * 
;;;                 "NON" 舍去Z值，返回二维坐标                     * 
;;;                 "=0"  Z值取0                                    * 
;;;                 "F1"  取第一个对象上的点                        * 
;;;                 "F2"  取第二个对象上的点                        * 
;;;                 "MAX" 取Z值大者                                 * 
;;;                 "MIN" 取Z值小者                                 * 
;;;      Fuzz   ----允许偏差值                                      * 
;;;返回：若成功，返回点位表；否则返回nil                            * 
;;;日期：zml84 于2007-11-05                                         * 
;;;                                                                 * 
(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 nil));_该处有弊端，需改进 
      (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 "NON") 
         (setq PT (list (car PT1) (cadr PT1))) 
        ) 
        ((= 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 i) 
  ;;取得实体的类型名称 
  (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 
;;;=================================================================* 
;|;; 
(defun C:TTt (/ S1 S2 OBJ1 OBJ2) 
  (if (and (setq S1 (entsel "\n线1: ")) 
     (setq S2 (entsel "\n线2: ")) 
      ) 
    (progn 
      (setq OBJ1 (vlax-ename->vla-object (car S1)) 
      OBJ2 (vlax-ename->vla-object (car S2)) 
      ) 
(princ "\n0\t\t") 
      (princ (ZL-GETINTERS OBJ1 OBJ2 0 "Max" nil)) 
(princ "\n1\t\t") 
      (princ (ZL-GETINTERS OBJ1 OBJ2 1 "Max" nil)) 
(princ "\n2\t\t") 
      (princ (ZL-GETINTERS OBJ1 OBJ2 2 "Max" nil)) 
(princ "\n3\t\t") 
      (princ (ZL-GETINTERS OBJ1 OBJ2 3 "Max" nil)) 
    ) 
  ) 
  (princ) 
) 
;;|;

kpl · 发表于 2022-12-15 03:26

tryhi 发表于 2016-4-28 13:14
是lisp

学习一下。。谢谢了

窗外流逝的时光 · 发表于 2016-4-27 21:08

跪求各位大神啊

tryhi · 发表于 2016-4-27 21:59

可以用vla-intersectwith

窗外流逝的时光 · 发表于 2016-4-27 22:34

tryhi 发表于 2016-4-27 21:59
可以用vla-intersectwith

十分感谢，我先查下用法

窗外流逝的时光 · 发表于 2016-4-27 23:45

tryhi 发表于 2016-4-27 21:59
可以用vla-intersectwith

您好，我查了下，您说的vla-intersectwith函数是VBA吗，这个我没用过，用lisp可以实现这个功能吗

窗外流逝的时光 · 发表于 2016-4-27 23:47

tryhi 发表于 2016-4-27 21:59
可以用vla-intersectwith

您好，我查了下，您说的vla-intersectwith函数是VBA吗，这个我没用过，用lisp可以实现这个功能吗

819534890 · 发表于 2016-4-28 09:49

窗外流逝的时光发表于 2016-4-27 23:47
您好，我查了下，您说的vla-intersectwith函数是VBA吗，这个我没用过，用lisp可以实现这个功能吗

你不想用vlisp，非要用lisp，就用(inters pt1 pt2 pt3 pt4 [onseg])
pt1 pt2是直线的两个端点；
提取出多段线的全部顶点，相邻两个为pt3、pt4；

tryhi · 发表于 2016-4-28 13:14

窗外流逝的时光发表于 2016-4-27 23:47
您好，我查了下，您说的vla-intersectwith函数是VBA吗，这个我没用过，用lisp可以实现这个功能吗

是lisp

(defun try-lst-div (lst nn / lst2)
(foreach n lst
(if (and lst2 (/= nn (length (car lst2))))
(setq lst2 (cons (append (car lst2) (list n)) (cdr lst2)))
(setq lst2 (cons (list n) lst2))
)
)
(reverse lst2)
)
(defun try-inters-en(en1 en2 / nn pp)
(if(or(null en1)(null en2)(equal en1 en2))nil
(progn
(setq pp (vla-intersectwith
(vlax-ename->vla-object en1)
(vlax-ename->vla-object en2)
acExtendnone
)
)
(setq nn (vlax-variant-value pp))
(if(/= -1(VLAX-SAFEARRAY-GET-U-BOUND nn 1))
(try-lst-div (vlax-safearray->list (vlax-variant-value pp))3)
)
))
)

(defun try-lst-div (lst nn / lst2) 
  (foreach n lst 
    (if (and lst2 (/= nn (length (car lst2)))) 
      (setq lst2 (cons (append (car lst2) (list n)) (cdr lst2))) 
      (setq lst2 (cons (list n) lst2)) 
    ) 
  ) 
  (reverse lst2) 
) 
(defun try-inters-en(en1 en2 / nn pp) 
        (if(or(null en1)(null en2)(equal en1 en2))nil 
                (progn 
                        (setq pp (vla-intersectwith 
                                                                 (vlax-ename->vla-object en1) 
                                                                 (vlax-ename->vla-object en2) 
                                                                 acExtendnone 
                                                         ) 
                        ) 
                        (setq nn (vlax-variant-value pp)) 
                        (if(/= -1(VLAX-SAFEARRAY-GET-U-BOUND nn 1)) 
                                (try-lst-div (vlax-safearray->list (vlax-variant-value pp))3) 
                                
                        ) 
                )) 
)

窗外流逝的时光 · 发表于 2016-4-28 18:34

819534890 发表于 2016-4-28 09:49
你不想用vlisp，非要用lisp，就用(inters pt1 pt2 pt3 pt4 [onseg])
pt1 pt2是直线的两个端点；
提取出 ...

您好，不是我非要用lisp，是我现在刚刚学习cad,现在也只会一点点lisp

窗外流逝的时光 · 发表于 2016-4-28 20:18

tryhi 发表于 2016-4-28 13:14
是lisp

您好，非常感谢，我好好研究一下

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

[函数] lisp求某一直线与多段线的交点

相关帖子