关于多段线

自贡黄明儒 · 发表于 2013-10-31 09:00:35

本帖最后由自贡黄明儒于 2014-11-7 09:43 编辑

;;164.1 [功能] 曲线是否封闭
;;164.2 [功能]使多段线封闭
;;164.3 [功能] 多段线端点列表
;;164.4 [功能] 矩形中点坐标
;;164.5 [功能] 参数param处的切线方向的角度
;;164.6 [功能] 参数param处的法线方向的角度
;;164.7 [功能] 曲线一点的切线方向的角度
;;164.8 [功能] 曲线一点的法线方向的角度
;;164.9 [功能] 去除多段线重点
;;164.10 [功能] 判断点是否在曲线上
;;164.11 [功能] 曲线长度
;;164.12 [功能] 多段线子段数量
;;164.13 [功能] 曲线中点
;;164.14 [功能] 曲线一点的参数param
;;164.15 [功能] 参数param处的坐标
;;164.16 [功能] 多段线第n子段的起点坐标
;;164.17 [功能] 多段线第n子段的终点坐标
;;164.18 [功能] 多段线所点击子段的两端点列表
;;164.19 [功能] 多段线所点击点最近的一个顶点
;;164.20 [功能] 多段线所点击子段param(索引)
;;164.21 [功能] 多段线所点击子段的起点坐标
;;164.22 [功能] 多段线所点击子段的终点坐标
;;164.23 [功能] 多段线所击点离起点近
;;164.24 [功能] 多段线所点击子段否是直线(返回nil是弧)
;;164.25 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心 by caoyin
;;164.26 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心
;;164.27 [功能] 判断多段线是否有圆弧(凸度/=0)的子段
;;164.28 [功能] 判断多段线是否有圆弧(凸度/=0)的子段
;;164.29 [功能] 连接线、弧成多段线
;;164.30 [功能] 构造矩形 by highflybird
;;164.31 [功能] 点表生成多段线
;;164.32 [功能] 3D多段线
;;164.33 [功能] 多段线反向(起点反成终点) byzml84
;;164.34 [功能] 多段线删除顶点
;;164.35 [功能] 多段线增加顶点
;;164.36 [功能] 多段线修改顶点
;;164.37 [功能] 多段线拷贝子段
;;164.38 [功能] 修改多段线子段
;;164.39 [功能] 修改多段线子段为直线
;;164.40 [功能] 点在封闭多段线内返回T，其余nil By 狂刀
;;164.41 [功能] 点在封闭多段线内返回T，其余nil By SmcTools
;;164.42 [功能] 判断点在封闭曲线内外，自交曲线不适用 By Gu_xl
;;164.43 [功能] 点在封闭多段线内返回T;线上0;外nil
;;164.44 [功能] 多段线弧段全改为直线段
;;164.45 [功能] 沿多段线取点，弧处按角度加密取点
;;164.46 [功能] 多段线自相交 by st788796

;;164.1 [功能] 曲线是否封闭 By 自贡黄明儒
;;示例(HH:isClosed (car (entsel)))
(defun HH:isClosed (obj)
(vlax-curve-isClosed obj)
)
;;164.2 [功能]使多段线封闭
(defun HH:MakeClosed (en / OBJ)
(cond ((equal (type en) 'ENAME) (setq obj (vlax-ename->vla-object en)))
((equal (type en) 'ENAME) (setq obj en))
(T (exit))
)
;;(if (equal (vlax-get obj 'Closed) 0) (vlax-put obj 'Closed -1))
(if (not (vlax-curve-isclosed obj)) ;(equal (vlax-get-property obj 'closed) :vlax-false)
(vla-put-closed obj :vlax-true)
)
)
;;164.3 [功能] 多段线端点列表 By 自贡黄明儒
;;示例(HH:PtLists (car (entsel)))
(defun HH:PtLists (en)
(mapcar 'cdr
(vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget en))
)
)
;;164.4 [功能] 矩形中点坐标 By 自贡黄明儒
;;示例(HH:RectangCen (car (entsel)))
(defun HH:RectangCen (en / PL X Y)
(setq pl (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget en)))
(setq pl (mapcar 'cdr pl))
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) (car pl) (caddr pl))
)
;;示例(HH:RectangCen1 (car (entsel)))
(defun HH:RectangCen1 (en / OBJ PL PL1 X Y)
(setq obj (vlax-ename->vla-object en))
(setq pl (vlax-safearray->list (vlax-variant-value (vla-get-coordinates obj))))
(setq pl1 (cddddr pl))
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0))
(list (car pl) (cadr pl))
(list (car pl1) (cadr pl1))
)
)
;;164.5 [功能] 参数param处的切线方向的角度
;;示例(HH:ParamFirstAngle (car (entsel)) 1)
;;注1 (vlax-curve-getFirstDeriv obj param) 函数计算的值是曲线上在参数值为param点处的切线方向
;;注2 param起始值为0
(defun HH:ParamFirstAngle (obj param)
(setq pt (vlax-curve-getpointatparam obj param))
(angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv obj param)))
)
;;164.6 [功能] 参数param处的法线方向的角度
;;示例(HH:ParamSecondAngle (car (entsel)) 1)
;;注:param处是直线，则返回0.0
(defun HH:ParamSecondAngle (obj param)
(setq pt (vlax-curve-getpointatparam obj param))
(angle pt (mapcar '+ pt (vlax-curve-getSecondDeriv obj param)))
)
;;164.7 [功能] 曲线一点的切线方向的角度
;;示例(HH:PtFirstAngle (car (entsel)) (getpoint))
(defun HH:PtFirstAngle (obj pt)
(setq param (vlax-curve-getParamAtPoint obj pt))
(angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv obj param)))
)
;;164.8 [功能] 曲线一点的法线方向的角度
;;示例(HH:PtSecondAngle (car (entsel)) (getpoint))
(defun HH:PtSecondAngle (obj pt)
(setq param (vlax-curve-getParamAtPoint obj pt))
(angle pt (mapcar '+ pt (vlax-curve-getSecondDeriv obj param)))
)
;;164.9 [功能] 去除多段线重点 By 自贡黄明儒
;;示例(HH:Remove (car (entsel)))
(defun HH:Remove (en / NEWDATA)
(foreach e (entget en)
(if (and (member e newdata) (= 10 (car e)))
nil
(setq newdata (cons e newdata))
)
)
(entmod (reverse newdata))
)
;;164.10 [功能] 判断点是否在曲线上
;;示例(HH:PtOnCurve (getpoint) (car (entsel)))
(defun HH:PtOnCurve (pt curve)
(equal pt (vlax-curve-getClosestPointTo curve pt) 0.00001)
)
;;164.11 [功能] 曲线长度
;;直线、圆弧、圆、多段线、优化多段线、样条曲线等图元
;;示例 (HH:GetCurveLength (car (entsel)))
(defun HH:GetCurveLength (curve)
(vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve))
)
;;164.12 [功能] 多段线子段数量
;;相当于组码90
;;示例 (HH:GetCurveNum (car (entsel)))
(defun HH:GetCurveNum (obj)
(if (vlax-curve-isClosed obj)
(fix (1- (vlax-curve-getendParam obj)))
(fix (vlax-curve-getendParam obj))
)
)
;;164.13 [功能] 曲线中点
;;示例 (HH:GetMidpointCurve (car (entsel)))
(defun HH:GetMidpointCurve (curve / d)
(setq d (/ (vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve)) 2))
(vlax-curve-getPointAtDist curve d)
)
;;164.14 [功能] 曲线一点的参数param
;;(HH:PtToParam (car (entsel)) (getpoint))
(defun HH:PtToParam (obj pt)
(vlax-curve-getParamAtPoint obj pt)
)
;;164.15 [功能] 参数param处的坐标
;;(HH:ParamTopt (car (entsel)) 0)
(defun HH:ParamTopt (obj param)
(vlax-curve-getPointAtParam obj param)
)
;;164.16 [功能] 多段线第n子段的起点坐标
;;示例 (HH:GetSegStratPt (car (entsel)) 0)
(defun HH:GetSegStratPt (curve n)
(vlax-curve-getPointAtParam curve (fix n))
)
;;164.17 [功能] 多段线第n子段的终点坐标
;;示例 (HH:GetSegEndPt (car (entsel)) 0)
(defun HH:GetSegEndPt (curve n)
(vlax-curve-getPointAtParam curve (1+ (fix n)))
)
;;164.18 [功能] 多段线所点击子段的两端点列表
;;示例(HH:PickSegEndPt (car(setq en(entsel))) (cadr en))
(defun HH:PickSegEndPt (obj p / pp n)
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp))
)
(list (vlax-curve-getPointAtParam obj n)
(vlax-curve-getPointAtParam obj (1+ n))
)
)
;;164.19 [功能] 多段线所点击点最近的一个顶点 By 自贡黄明儒
;;示例(HH:PickClosePt (car(setq en(entsel))) (cadr en))
(defun HH:PickClosePt (obj p / N P1 P2 PP)
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp))
)
(setq p1 (vlax-curve-getPointAtParam obj n))
(setq p2 (vlax-curve-getPointAtParam obj (1+ n)))
(if (< (distance pp p1) (distance pp p2))
p1
p2
)
)
;;164.20 [功能] 多段线所点击子段param(索引) By 自贡黄明儒
;;示例(HH:PickSegIndex (car(setq en(entsel))) (cadr en))
(defun HH:PickSegIndex (obj p / PP)
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0)))
(fix (vlax-curve-getparamatpoint obj pp))
)
;;164.21 [功能] 多段线所点击子段的起点坐标 By 自贡黄明儒
;;示例(HH:PickSegStratPt (car(setq en(entsel))) (cadr en))
(defun HH:PickSegStratPt (obj p / pp n)
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp))
)
(vlax-curve-getPointAtParam obj n)
)
;;164.22 [功能] 多段线所点击子段的终点坐标 By 自贡黄明儒
;;示例(HH:PickSegEndPt (car(setq en(entsel))) (cadr en))
(defun HH:PickSegEndPt (obj p / pp n)
(setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))
n (fix (vlax-curve-getparamatpoint obj pp))
)
(vlax-curve-getPointAtParam obj (1+ n))
)
;;164.23 [功能] 多段线所击点离起点近 By 自贡黄明儒
;;示例(HH:PickToStart (car(setq en(entsel))) (cadr en))
(defun HH:PickToStart (curve p / L1 L2 PP)
(setq pp (vlax-curve-getclosestpointto curve (trans p 1 0)))
(setq L2 (vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve)))
(setq L1 (vlax-curve-getDistAtPoint curve pp))
(> (- L2 L1) L1)
)
;;164.24 [功能] 多段线所击子段是否是直线(返回nil是弧) By 自贡黄明儒
;;示例(HH:PickArc (car(setq en(entsel))) (cadr en))
(defun HH:PickArc (curve p / PP)
(setq pp (vlax-curve-getclosestpointto curve (trans p 1 0)))
(setq pp (vlax-curve-getSecondDeriv
curve
(fix (vlax-curve-getparamatpoint curve pp))
)
)
(equal pp '(0.0 0.0 0.0))
)
;;164.25 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心 by caoyin
;;(HH:GetCenter1 (entsel "\n选择多段线弧段: "))
(defun HH:GetCenter1 (EP / E P)
(mapcar 'set '(E P) EP)
(setq P (apply 'vlax-curve-getClosestPointTo EP))
(mapcar '+
P
(vlax-curve-getsecondderiv
E
(vlax-curve-getParamAtPoint E P)
)
)
)
;;164.26 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心
;;(HH:GetCenter2 (car(setq en(entsel))) (cadr en))
(defun HH:GetCenter2 (curve p / PP)
(setq pp (vlax-curve-getclosestpointto curve (trans p 1 0)))
(mapcar '+
pp
(vlax-curve-getsecondderiv
curve
(vlax-curve-getParamAtPoint curve pp)
)
)
)
;;164.27 [功能] 判断多段线是否有圆弧(凸度/=0)的子段
;;(HH:checkarc1 (car (entsel)))
(defun HH:checkarc1 (en / BU N OBJ PLIST)
(setq obj (vlax-ename->vla-object en))
(setq plist (vlax-safearray->list (vlax-variant-value (vla-get-coordinates obj))))
(setq n 0)
(repeat (/ (length plist) 2)
(if (/= (vla-getbulge obj n) 0)
(setq bu T)
)
(setq n (+ n 1))
)
bu
)
;;164.28 [功能] 判断多段线是否有圆弧(凸度/=0)的子段
;;(HH:checkarc2 (car (entsel)))
(defun HH:checkarc2 (en / G)
(setq G (vl-remove-if-not '(lambda (x) (= (car x) 42)) (entget en)))
(not (vl-every 'zerop (mapcar 'cdr G))) ;(vl-remove 0.0 (mapcar 'cdr G))
)
;;164.29 [功能] 连接线、弧成多段线
;;(HH:JionToPolyline)
(defun HH:JionToPolyline (/ PET SS)
(setq pet (getvar "PEDITACCEPT"))
(setvar "PEDITACCEPT" 1)
(while (setq ss (ssget '((0 . "ARC,*LINE"))))
(command "_.pedit" (ssname ss 0) "j" ss "" "")
)
(setvar "PEDITACCEPT" pet)
(princ)
)
;;164.30 [功能] 构造矩形 by highflybird
(defun Make-Rectange (pt1 pt2)
(entmake
(list
'(0 . "LWPOLYLINE") ;轻多段线
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4) ;四个顶点
'(70 . 1) ;闭合
(cons 38 (caddr pt1)) ;高程
(cons 10 (list (car pt1) (cadr pt1))) ;左下角
(cons 10 (list (car pt2) (cadr pt1))) ;右下角
(cons 10 (list (car pt2) (cadr pt2))) ;右上角
(cons 10 (list (car pt1) (cadr pt2))) ;左上角
(cons 210 '(0 0 1)) ;法线方向
)
)
)
;;164.31 [功能] 点表生成多段线
(defun Make-LWPOLYLINE (lst / PT)
(entmake (append (list '(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst))
)
(mapcar '(lambda (pt) (cons 10 pt)) lst)
)
)
)
;;164.32 [功能] 多段线反向(起点反成终点) byzml84
;;(HH:LWPOLYLINEFX (car (entsel)))
(defun HH:LWPOLYLINEFX (EN / A B C D ENT LST LST1 TMP)
(setq ENT (entget EN))
(setq tmp ent)
(while (setq tmp (member (assoc 10 tmp) tmp))
(setq a (assoc 10 tmp)
b (cons 40 (cdr (assoc 41 tmp)))
c (cons 41 (cdr (assoc 40 tmp)))
d (cons 42 (- (cdr (assoc 42 tmp))))
LST (append (list b c d a) LST)
)
(setq tmp (cddddr tmp))
)
(repeat 3 (setq LST (append (cdr lst) (list (car lst)))))
(setq lst1 (reverse (cdr (member (assoc 10 ent) (reverse ent)))))
(entmod (append lst1 lst '((210 0 0 1))))
)

;;164.1 [功能] 曲线是否封闭 By 自贡黄明儒 
;;示例(HH:isClosed (car (entsel))) 
(defun HH:isClosed (obj) 
  (vlax-curve-isClosed obj) 
) 
;;164.2 [功能]使多段线封闭 
(defun HH:MakeClosed (en / OBJ) 
  (cond        ((equal (type en) 'ENAME) (setq obj (vlax-ename->vla-object en))) 
        ((equal (type en) 'ENAME) (setq obj en)) 
        (T (exit)) 
  ) 
  ;;(if (equal (vlax-get obj 'Closed) 0) (vlax-put obj 'Closed -1)) 
  (if (not (vlax-curve-isclosed obj))                            ;(equal (vlax-get-property obj 'closed) :vlax-false) 
    (vla-put-closed obj :vlax-true) 
  ) 
) 
;;164.3 [功能] 多段线端点列表 By 自贡黄明儒 
;;示例(HH:PtLists (car (entsel))) 
(defun HH:PtLists (en) 
  (mapcar 'cdr 
          (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget en)) 
  ) 
) 
 
;;164.4 [功能] 矩形中点坐标 By 自贡黄明儒 
;;示例(HH:RectangCen (car (entsel))) 
(defun HH:RectangCen (en / PL X Y) 
  (setq pl (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget en))) 
  (setq pl (mapcar 'cdr pl)) 
  (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) (car pl) (caddr pl)) 
) 
;;示例(HH:RectangCen1 (car (entsel))) 
(defun HH:RectangCen1 (en / OBJ PL PL1 X Y) 
  (setq obj (vlax-ename->vla-object en)) 
  (setq pl (vlax-safearray->list (vlax-variant-value (vla-get-coordinates obj)))) 
  (setq pl1 (cddddr pl)) 
  (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) 
          (list (car pl) (cadr pl)) 
          (list (car pl1) (cadr pl1)) 
  ) 
) 
 
;;164.5 [功能] 参数param处的切线方向的角度 
;;示例(HH:ParamFirstAngle (car (entsel)) 1) 
;;注1 (vlax-curve-getFirstDeriv obj param) 函数计算的值是曲线上在参数值为param点处的切线方向 
;;注2 param起始值为0 
(defun HH:ParamFirstAngle (obj param) 
  (setq pt (vlax-curve-getpointatparam obj param)) 
  (angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv obj param))) 
) 
 
;;164.6 [功能] 参数param处的法线方向的角度 
;;示例(HH:ParamSecondAngle (car (entsel)) 1) 
;;注:param处是直线，则返回0.0 
(defun HH:ParamSecondAngle (obj param) 
  (setq pt (vlax-curve-getpointatparam obj param)) 
  (angle pt (mapcar '+ pt (vlax-curve-getSecondDeriv obj param))) 
) 
 
;;164.7 [功能] 曲线一点的切线方向的角度 
;;示例(HH:PtFirstAngle (car (entsel)) (getpoint)) 
(defun HH:PtFirstAngle (obj pt) 
  (setq param (vlax-curve-getParamAtPoint obj pt)) 
  (angle pt (mapcar '+ pt (vlax-curve-getFirstDeriv obj param))) 
) 
 
;;164.8 [功能] 曲线一点的法线方向的角度 
;;示例(HH:PtSecondAngle (car (entsel)) (getpoint)) 
(defun HH:PtSecondAngle        (obj pt) 
  (setq param (vlax-curve-getParamAtPoint obj pt)) 
  (angle pt (mapcar '+ pt (vlax-curve-getSecondDeriv obj param))) 
) 
 
;;164.9 [功能] 去除多段线重点  By 自贡黄明儒 
;;示例(HH:Remove (car (entsel))) 
(defun HH:Remove (en / NEWDATA) 
  (foreach e (entget en) 
    (if        (and (member e newdata) (= 10 (car e))) 
      nil 
      (setq newdata (cons e newdata)) 
    ) 
  ) 
  (entmod (reverse newdata)) 
) 
 
;;164.10 [功能] 判断点是否在曲线上 
;;示例(HH:PtOnCurve (getpoint) (car (entsel))) 
(defun HH:PtOnCurve (pt curve) 
  (equal pt (vlax-curve-getClosestPointTo curve pt) 0.00001) 
) 
 
;;164.11 [功能] 曲线长度 
;;直线、圆弧、圆、多段线、优化多段线、样条曲线等图元 
;;示例 (HH:GetCurveLength (car (entsel))) 
(defun HH:GetCurveLength (curve) 
  (vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve)) 
) 
 
;;164.12 [功能] 多段线子段数量 
;;相当于组码90 
;;示例 (HH:GetCurveNum (car (entsel))) 
(defun HH:GetCurveNum (obj) 
  (if (vlax-curve-isClosed obj) 
    (fix (1- (vlax-curve-getendParam obj))) 
    (fix (vlax-curve-getendParam obj)) 
  ) 
) 
 
;;164.13 [功能] 曲线中点 
;;示例 (HH:GetMidpointCurve (car (entsel))) 
(defun HH:GetMidpointCurve (curve / d) 
  (setq d (/ (vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve)) 2)) 
  (vlax-curve-getPointAtDist curve d) 
) 
 
;;164.14 [功能] 曲线一点的参数param 
;;(HH:PtToParam (car (entsel)) (getpoint)) 
(defun HH:PtToParam (obj pt) 
  (vlax-curve-getParamAtPoint obj pt) 
) 
;;164.15 [功能] 参数param处的坐标 
;;(HH:ParamTopt (car (entsel)) 0) 
(defun HH:ParamTopt (obj param) 
  (vlax-curve-getPointAtParam obj param) 
) 
;;164.16 [功能] 多段线第n子段的起点坐标 
;;示例 (HH:GetSegStratPt (car (entsel)) 0) 
(defun HH:GetSegStratPt        (curve n) 
  (vlax-curve-getPointAtParam curve (fix n)) 
) 
;;164.17 [功能] 多段线第n子段的终点坐标 
;;示例 (HH:GetSegEndPt (car (entsel)) 0) 
(defun HH:GetSegEndPt (curve n) 
  (vlax-curve-getPointAtParam curve (1+ (fix n))) 
) 
 
;;164.18 [功能] 多段线所点击子段的两端点列表 
;;示例(HH:PickSegEndPt (car(setq en(entsel))) (cadr en)) 
(defun HH:PickSegEndPt (obj p / pp n) 
  (setq        pp (vlax-curve-getclosestpointto obj (trans p 1 0)) 
        n  (fix (vlax-curve-getparamatpoint obj pp)) 
  ) 
  (list        (vlax-curve-getPointAtParam obj n) 
        (vlax-curve-getPointAtParam obj (1+ n)) 
  ) 
) 
 
;;164.19 [功能] 多段线所点击点最近的一个顶点  By 自贡黄明儒 
;;示例(HH:PickClosePt (car(setq en(entsel))) (cadr en)) 
(defun HH:PickClosePt (obj p / N P1 P2 PP) 
  (setq        pp (vlax-curve-getclosestpointto obj (trans p 1 0)) 
        n  (fix (vlax-curve-getparamatpoint obj pp)) 
  ) 
  (setq p1 (vlax-curve-getPointAtParam obj n)) 
  (setq p2 (vlax-curve-getPointAtParam obj (1+ n))) 
  (if (< (distance pp p1) (distance pp p2)) 
    p1 
    p2 
  ) 
) 
;;164.20 [功能] 多段线所点击子段param(索引)  By 自贡黄明儒 
;;示例(HH:PickSegIndex (car(setq en(entsel))) (cadr en)) 
(defun HH:PickSegIndex (obj p / PP) 
  (setq pp (vlax-curve-getclosestpointto obj (trans p 1 0))) 
  (fix (vlax-curve-getparamatpoint obj pp)) 
) 
;;164.21 [功能] 多段线所点击子段的起点坐标  By 自贡黄明儒 
;;示例(HH:PickSegStratPt (car(setq en(entsel))) (cadr en)) 
(defun HH:PickSegStratPt (obj p / pp n) 
  (setq        pp (vlax-curve-getclosestpointto obj (trans p 1 0)) 
        n  (fix (vlax-curve-getparamatpoint obj pp)) 
  ) 
  (vlax-curve-getPointAtParam obj n) 
) 
;;164.22 [功能] 多段线所点击子段的终点坐标 By 自贡黄明儒 
;;示例(HH:PickSegEndPt (car(setq en(entsel))) (cadr en)) 
(defun HH:PickSegEndPt (obj p / pp n) 
  (setq        pp (vlax-curve-getclosestpointto obj (trans p 1 0)) 
        n  (fix (vlax-curve-getparamatpoint obj pp)) 
  ) 
  (vlax-curve-getPointAtParam obj (1+ n)) 
) 
;;164.23 [功能] 多段线所击点离起点近 By 自贡黄明儒 
;;示例(HH:PickToStart (car(setq en(entsel))) (cadr en)) 
(defun HH:PickToStart (curve p / L1 L2 PP) 
  (setq pp (vlax-curve-getclosestpointto curve (trans p 1 0))) 
  (setq L2 (vlax-curve-getDistAtParam curve (vlax-curve-getEndParam curve))) 
  (setq L1 (vlax-curve-getDistAtPoint curve pp)) 
  (> (- L2 L1) L1) 
) 
;;164.24 [功能] 多段线所击子段是否是直线(返回nil是弧) By 自贡黄明儒 
;;示例(HH:PickArc (car(setq en(entsel))) (cadr en)) 
(defun HH:PickArc (curve p / PP) 
  (setq pp (vlax-curve-getclosestpointto curve (trans p 1 0))) 
  (setq        pp (vlax-curve-getSecondDeriv 
             curve 
             (fix (vlax-curve-getparamatpoint curve pp)) 
           ) 
  ) 
  (equal pp '(0.0 0.0 0.0)) 
) 
 
;;164.25 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心 by caoyin 
;;(HH:GetCenter1 (entsel "\n选择多段线弧段: ")) 
(defun HH:GetCenter1 (EP / E P) 
  (mapcar 'set '(E P) EP) 
  (setq P (apply 'vlax-curve-getClosestPointTo EP)) 
  (mapcar '+ 
          P 
          (vlax-curve-getsecondderiv 
            E 
            (vlax-curve-getParamAtPoint E P) 
          ) 
  ) 
) 
;;164.26 [功能] 求多段线上的弧段(圆或圆弧也有效)的圆心 
;;(HH:GetCenter2 (car(setq en(entsel))) (cadr en)) 
(defun HH:GetCenter2 (curve p / PP) 
  (setq pp (vlax-curve-getclosestpointto curve (trans p 1 0))) 
  (mapcar '+ 
          pp 
          (vlax-curve-getsecondderiv 
            curve 
            (vlax-curve-getParamAtPoint curve pp) 
          ) 
  ) 
) 
 
;;164.27 [功能] 判断多段线是否有圆弧(凸度/=0)的子段 
;;(HH:checkarc1 (car (entsel))) 
(defun HH:checkarc1 (en / BU N OBJ PLIST) 
  (setq obj (vlax-ename->vla-object en)) 
  (setq plist (vlax-safearray->list (vlax-variant-value (vla-get-coordinates obj)))) 
  (setq n 0) 
  (repeat (/ (length plist) 2) 
    (if        (/= (vla-getbulge obj n) 0) 
      (setq bu T) 
    ) 
    (setq n (+ n 1)) 
  ) 
  bu 
) 
;;164.28 [功能] 判断多段线是否有圆弧(凸度/=0)的子段 
;;(HH:checkarc2 (car (entsel))) 
(defun HH:checkarc2 (en / G) 
  (setq G (vl-remove-if-not '(lambda (x) (= (car x) 42)) (entget en))) 
  (not (vl-every 'zerop (mapcar 'cdr G)))                    ;(vl-remove 0.0 (mapcar 'cdr G)) 
) 
 
;;164.29 [功能] 连接线、弧成多段线 
;;(HH:JionToPolyline) 
(defun HH:JionToPolyline (/ PET SS) 
  (setq pet (getvar "PEDITACCEPT")) 
  (setvar "PEDITACCEPT" 1) 
  (while (setq ss (ssget '((0 . "ARC,*LINE")))) 
    (command "_.pedit" (ssname ss 0) "j" ss "" "") 
  ) 
  (setvar "PEDITACCEPT" pet) 
  (princ) 
) 
 
;;164.30 [功能] 构造矩形 by highflybird 
(defun Make-Rectange (pt1 pt2) 
  (entmake 
    (list 
      '(0 . "LWPOLYLINE")                                    ;轻多段线 
      '(100 . "AcDbEntity") 
      '(100 . "AcDbPolyline") 
      '(90 . 4)                                                    ;四个顶点 
      '(70 . 1)                                                    ;闭合 
      (cons 38 (caddr pt1))                                    ;高程 
      (cons 10 (list (car pt1) (cadr pt1)))                    ;左下角 
      (cons 10 (list (car pt2) (cadr pt1)))                    ;右下角 
      (cons 10 (list (car pt2) (cadr pt2)))                    ;右上角 
      (cons 10 (list (car pt1) (cadr pt2)))                    ;左上角 
      (cons 210 '(0 0 1))                                    ;法线方向 
    ) 
  ) 
) 
 
;;164.31 [功能] 点表生成多段线 
(defun Make-LWPOLYLINE (lst / PT) 
  (entmake (append (list '(0 . "LWPOLYLINE") 
                         '(100 . "AcDbEntity") 
                         '(100 . "AcDbPolyline") 
                         (cons 90 (length lst)) 
                   ) 
                   (mapcar '(lambda (pt) (cons 10 pt)) lst) 
           ) 
  ) 
) 
 
;;164.32 [功能] 多段线反向(起点反成终点) byzml84 
;;(HH:LWPOLYLINEFX (car (entsel))) 
(defun HH:LWPOLYLINEFX (EN / A B C D ENT LST LST1 TMP) 
  (setq ENT (entget EN)) 
  (setq tmp ent) 
  (while (setq tmp (member (assoc 10 tmp) tmp)) 
    (setq a   (assoc 10 tmp) 
          b   (cons 40 (cdr (assoc 41 tmp))) 
          c   (cons 41 (cdr (assoc 40 tmp))) 
          d   (cons 42 (- (cdr (assoc 42 tmp)))) 
          LST (append (list b c d a) LST) 
    ) 
    (setq tmp (cddddr tmp)) 
  ) 
  (repeat 3 (setq LST (append (cdr lst) (list (car lst))))) 
  (setq lst1 (reverse (cdr (member (assoc 10 ent) (reverse ent))))) 
  (entmod (append lst1 lst '((210 0 0 1)))) 
)

;;164.33 [功能] 多段线删除顶点 By 自贡黄明儒
(defun HH:delLwpolyPt (/ EN ENT L1 L2 P P1 P2 P90 SS X Y)
 (setq p1 (getpoint))
 (setq p2 (getcorner p1))
 (if (setq ss (ssget "C" p1 p2 '((0 . "LWPOLYLINE"))))
(progn
 (setq en (ssname ss 0))
 (setq ENT (entget EN))
 (if (> (setq P90 (cdr (assoc 90 ent))) 2)
 (progn
 (setq p (mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) p1 p2))
 (setq p (vlax-curve-getclosestpointto en (trans p 1 0)))
 (setq p1 (HH:PickClosePt en p))
 (setq p1 (list 10 (car p1) (cadr p1)))
 (setq L2 (cddddr (member p1 ent))) ;后段
 (setq L1 (reverse (cdr (member p1 (reverse ent))))) ;前段
 (setq ent (append L1 L2))
 (entmod (subst (cons 90 (1- P90)) (assoc 90 ent) ent))
 )
 )
)
 )
)
;;示例(HH:delLwpolyPt1 (car(setq en(entsel))) (cadr en)) By 自贡黄明儒
(defun HH:delLwpolyPt1 (en p / ENT L1 L2 P1)
 (setq ENT (entget en))
 (setq p (vlax-curve-getclosestpointto en (trans p 1 0)))
 (setq p1 (HH:PickClosePt en p)) ;离p最近的顶点
 (setq p1 (list 10 (car p1) (cadr p1)))
 (setq L2 (cdr (member p1 ent))) ;后段
 (setq L1 (reverse (cdr (member p1 (reverse ent))))) ;前段
 (entmod (append L1 L2))
)
;;164.34 [功能] 多段线增加顶点 By 自贡黄明儒
;;示例(HH:LwAddVertex (car(setq en(entsel))) (cadr en))
(defun HH:LwAddVertex (en pt / EN GR N PP)
 ;;增加一个顶点
 (defun LwAddVertex (obj index pt bugle sw ew)
(vlax-invoke obj 'addvertex index pt)
(vla-setbulge obj index bugle)
(vla-setwidth obj index sw ew)
 )
 (setq pp (vlax-curve-getClosestPointTo en (trans pt 1 0)))
 (setq n (fix (vlax-curve-getParamAtPoint en pp)))
 (setq obj (vlax-ename->vla-object en))
 (vla-GetWidth obj n 'sw 'ew)
 (setq pp (getpoint "\n 新增点 "))
 (setq pp (mapcar '+ '(0 0) pp))
 (vl-catch-all-apply 'LwAddVertex (list obj (1+ n) pp 0 sw sw))
)

;;164.35 [功能] 多段线修改顶点 By 自贡黄明儒
;;示例(HH:ModifyVertex (car(setq en(entsel))) (cadr en) (getpoint))
(defun HH:ModifyVertex (en pt newPt / ENT L1 L2 NPT P P10)
 (setq p (HH:PickClosePt en pt))
 (setq p10 (list 10 (car p) (cadr p)))
 (setq ent (entget en))
 (setq L2 (cdr (member p10 ent)))
 (setq L1 (reverse (cdr (member p10 (reverse ent)))))
 (setq Npt (list (list 10 (car newPt) (cadr newPt))))
 (entmod (append L1 Npt L2))
)
;;(HH:ModifyVertex1 (car(setq en(entsel))) (cadr en)) By 自贡黄明儒
(defun HH:ModifyVertex1 (en p / ENT GR L1 L2 NPT P10)
 (setq ent (entget en))
 (setq pt (HH:PickClosePt en p))
 (setq p10 (list 10 (car pt) (cadr pt)))
 (setq L2 (cdr (member p10 ent)))
 (setq L1 (reverse (cdr (member p10 (reverse ent)))))
 (while (and (setq gr (grread 5)) (= (car gr) 5))
(setq Npt (list (list 10 (car (cadr gr)) (cadr (cadr gr)))))
(entmod (append L1 Npt L2))
 )
)

;;164.36 [功能] 多段线拷贝子段 By 自贡黄明儒
;;(HH:CopyLwSeg (car(setq en(entsel))) (cadr en))
(defun HH:CopyLwSeg (en p / ENT L0 L1 L2 LASTENT N P1 PP TEM)
 (setq pp (vlax-curve-getClosestPointTo en p))
 (setq n (fix (vlax-curve-getParamAtPoint en pp)))
 (setq p1 (vlax-curve-getPointAtParam en n))
 (setq p1 (list 10 (car p1) (cadr p1)))
 (setq ent (entget en))
 (setq tem (member p1 ent))
 (repeat 8 (setq L0 (cons (car tem) L0)) (setq tem (cdr tem)))
 (setq L0 (reverse L0))
 (setq L2 (list (last tem)))
 (setq L1 (list
 '(0 . "LWPOLYLINE")
 '(100 . "AcDbEntity")
 '(100 . "AcDbPolyline")
 '(90 . 2)
 )
 )
 (entmake (append L1 l0 L2))
 (setq Lastent (entlast))
 (command "_.move" Lastent "" pp pause)
)

;;164.37 [功能] 修改多段线子段 By 自贡黄明儒
;;示例(HH:ModifySeg (car(setq en(entsel))) (cadr en))
(defun HH:ModifySeg (en p / ENT GR I L1 L2 N P1 P2 P42 PP X Y)
 ;;133.1 [功能] 旋转一个点(见113)
 ;;Rotate 'pnt'点 from a base point of 'p1' and through an angle of 'ang' (in radians)
 (defun MJ:rotate_pnt (pnt p1 ang)
(polar p1 (+ (angle p1 pnt) ang) (distance p1 pnt))
 )
 ;;两点之中点
 (defun mid (p1 p2 / X Y)
(mapcar '(lambda (X Y) (/ (+ X Y) 2.0)) p1 p2)
 )
 ;;已知三点p1 p2 p，求组码42
 (defun my42 (p1 p2 pt / CEN D H P1P2 P1T P2P1 PT1 R)
(setq d (/ (distance p1 p2) 2.0))
(setq p1p2 (mid p1 p2))
(setq p2p1 (MJ:rotate_pnt p1 p1p2 (/ pi 2)))
(setq pt1 (mid p1 pt))
(setq p1t (MJ:rotate_pnt p1 pt1 (/ pi 2)))
(setq cen (inters p1p2 p2p1 pt1 p1t nil))
(setq h (car (trans (mapcar '- cen p1) 0 (mapcar '- p1 p2))))
(setq r (distance cen p1))
(if (MINUSP h)
 (setq r (+ r h))
 (setq r (- h r))
)
(/ r d)
 )

 (setq pp (vlax-curve-getClosestPointTo en p))
 (setq n (fix (vlax-curve-getParamAtPoint en pp)))
 (setq p1 (vlax-curve-getPointAtParam en n))
 (setq p2 (vlax-curve-getPointAtParam en (1+ n)))
 (setq ent (entget en))
 (setq i 0)
 (while (or (/= (caar ent) 42)
 (if (< i n)
 (setq i (1+ i))
 )
 )
(setq L1 (cons (car ent) L1)
 ent (cdr ent)
)
 )
 (setq L1 (REVERSE L1))
 (setq L2 (cdr ent))
 (while (and (setq gr (grread 5)) (= (car gr) 5))
(setq p42 (cons 42 (my42 p1 p2 (cadr gr))))
(entmod (append L1 (list p42) L2))
 )
 (princ)
)

;;164.38 [功能] 修改多段线子段为直线 By 自贡黄明儒
;;(HH:ModifySegLine (car(setq en(entsel))) (cadr en))
(defun HH:ModifySegLine (en p / ENT I L1 L2 N P1 P2 PP)
 (setq pp (vlax-curve-getClosestPointTo en p))
 (setq n (fix (vlax-curve-getParamAtPoint en pp)))
 (setq p1 (vlax-curve-getPointAtParam en n))
 (setq p2 (vlax-curve-getPointAtParam en (1+ n)))
 (setq ent (entget en))
 (setq i 0)
 (while (or (/= (caar ent) 42)
 (if (< i n)
 (setq i (1+ i))
 )
 )
(setq L1 (cons (car ent) L1)
 ent (cdr ent)
)
 )
 (setq L1 (REVERSE L1))
 (setq L2 (cdr ent))
 (entmod (append L1 (list (cons 42 0)) L2))
 (princ)
)

;;164.39.1 [功能] 点在封闭多边形内返回T;线上0;外nil
;;改编自狂刀的程序(应该简洁而完美) By 自贡黄明儒
;;(PtInorOut1 (car (entsel)) (getpoint))
(defun PtInorOut1 (en pt / P1 P2 PP PT PTS)
 (setq pp (vlax-curve-getClosestPointTo en pt))
 (if (equal pp pt 0.00001)
0
(progn
 (setq pts (HH:PtLists en))
 (setq pts (MAPCAR '(LAMBDA (p1 p2) (REM (- (ANGLE pt p1) (ANGLE pt p2)) PI))
 (CONS (LAST pts) pts)
 pts
 )
 )
 (equal (ABS (APPLY '+ pts)) PI)
)
 )
)

;;164.39.2 [功能] 点在封闭多边形内返回T，其余nil By SmcTools
;;(PtInorOut2 (car(entsel))(getpoint))
(defun PtInorOut2 (en pt / I N PT_LIST VA VA_COUNT)
 (setq pt_list (HH:PtLists en))
 (setq i 0
 va_count 0
 n (length pt_list)
 pt_list (append pt_list (list (car pt_list)))
 )
 (repeat n
(setq va (- (angle pt (nth i pt_list))
 (angle pt (nth (1+ i) pt_list))
 )
)
(cond ((> va pi) (setq va (- va pi)))
 ((< va (* -1 pi)) (setq va (+ va pi)))
)
(setq va_count (+ va_count va)
 i (1+ i)
)
 )
 (equal (abs va_count) pi)
)

;;164.40 [功能] 判断点在封闭曲线内外，自交曲线不适用 By Gu_xl 2012.07.31
;;返回: 点在封闭曲线内返回T;线上0;外nil
;;测试: (gxl-PtInCurveP (car(entsel "\n选择曲线:")) (getpoint))
(defun gxl-PtInCurveP (POLY PT / CP LW MINP MAXP MINX
 MINY MAXX MAXY X Y LST CLOCKWISEP
 ENDPARAM CURVELENGTH PARAM DIST D1 D2
 DEV
 )
 (cond
((equal pt (vlax-curve-getclosestpointto poly pt) 1e-8) 0) ;_ 点在曲线上 T
((progn
 (vla-GetBoundingBox
 (setq lw (vlax-ename->vla-object POLY))
 'MinP
 'MaxP
 )
 (setq MinP (vlax-safearray->list MinP))
 (setq MaxP (vlax-safearray->list MaxP))
 (setq minx (car MinP)
 miny (cadr MinP)
 maxx (car MaxP)
 maxy (cadr MaxP)
 x (car pt)
 y (cadr pt)
 )
 (or (< x minx)
 (> x maxx)
 (< y miny)
 (> y maxy)
 )
 )
 NIL ;_ 点在曲线最小包围盒外 nil
)
(t
 (setq
 lst (mapcar
 (function
 (lambda (x)
 (vlax-curve-getParamAtPoint
 lw
 (vlax-curve-getClosestPointTo lw x)
 )
 )
 )
 (list minp
 (list minx maxy)
 MaxP
 (list maxx miny)
 )
 )
 ) ;_ 最小包围盒点在曲线上的投影点的参数表
 (setq ClockwiseP
 (if (or
 (<= (car lst) (cadr lst) (caddr lst) (cadddr lst))
 (<= (cadr lst) (caddr lst) (cadddr lst) (car lst))
 (<= (caddr lst) (cadddr lst) (car lst) (cadr lst))
 (<= (cadddr lst) (car lst) (cadr lst) (caddr lst))
 ) ;_ or
 t
 ) ;_ if
 ) ;_ 判断曲线是否为顺时针，顺时针 = T
 (setq endparam (vlax-curve-getendparam poly)
 curvelength (vlax-curve-getDistAtParam poly endparam) ;_ 曲线长度
 )
 (setq param (vlax-curve-getparamatpoint poly cp)
 dist (vlax-curve-getDistAtParam poly param)
 )
 (if (equal param (fix param) 1e-8)
 (progn
 (setq d1 (- dist 1e-8))
 (if (minusp d1)
 (setq d1 (+ curvelength d1))
 )
 (setq d2 (+ dist 1e-8))
 (if (> d2 curvelength)
 (setq d2 (- d2 curvelength))
 )
 (if (< (distance pt (vlax-curve-getpointatdist poly d1))
 (distance pt (vlax-curve-getpointatdist poly d2))
 )
 (setq param (vlax-curve-getparamatdist poly d1))
 (setq param (vlax-curve-getparamatdist poly d2))
 )
 )
 )
 (setq dev (vlax-curve-getFirstDeriv poly param)
 cp (vlax-curve-getpointatparam poly param)
 )
 (= ClockwiseP
 (
 (lambda (p1 p2 p3)
 (<
 (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
 (* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
 )
 )
 pt
 cp
 (mapcar '+ cp dev)
 )
 )
)
 )
)

;;164.41.1 [功能] 点在封闭曲线内返回T;线上0;外nil
;;封闭曲线必须全可见,还是caoyin的那个程序好 By 自贡黄明儒
;;(PtInorOut (car(entsel))(getpoint))
(defun PtInorOut (en p / AREA AREA1 EN1 PP)
 (setq pp (vlax-curve-getclosestpointto en (trans p 1 0)))
 (if (equal pp p 0.00001)
0
(progn
 (setq area (vlax-get (vlax-ename->vla-object en) 'area))
 (command "_.offset" "" en p "");用(vla-offset obj 0.00001)比较距离
 (setq area1 (vlax-get (vlax-ename->vla-object en1) 'area))
 (entdel en1)
 (> area1 area)
)
 )
)

;;164.41.2 [功能] 点在封闭多段线内返回T;线上0;外nil
;;封闭曲线必须全可见
;;(PtInorOut3 (car(entsel))(getpoint))
(defun PtInorOut3 (en p / EN1 PP SS)
 (setq pp (vlax-curve-getclosestpointto en (trans p 1 0)))
 (if (equal pp p 0.00001)
0
(progn
 (entmake (list '(0 . "POINT") (cons 10 p)))
 (setq en1 (entlast))
 (if (and (setq ss (ssget "wp" (HH:PtLists en)))
 (ssmemb en1 ss)
 )
 (setq ss T)
 )
 (entdel en1)
 ss
)
 )
)

;;164.42 [功能] 多段线弧段全改为直线段 By 自贡黄明儒
;;(HH:ModifySegLine1 (car(setq en(entsel))))
(defun HH:ModifySegLine1 (en / X)
 (entmod
(mapcar '(lambda (x)
 (if (equal (car x) 42)
 (cons 42 0)
 x
 )
 )
 (entget en)
)
 )
)

;;多段线自相交 by st788796
(defun rrr (e / getlst ep obj pts ptl pams il)
 (defun Getlst (n / i il)
(setq i (fix n))
(repeat i (setq il (cons (setq n (1- n)) il)))
il
 )
 (setq obj (vlax-ename->vla-object e)
ep (vlax-curve-getendparam e)
 )
 (if (setq pts (vlax-invoke obj 'IntersectWith obj 0))
(progn
 (while pts
(setq ptl (cons (list (car pts) (cadr pts) (caddr pts)) ptl)
 pts (cdddr pts)
)
 )
 (setq il (cdr (getlst ep))
 pams (mapcar '(lambda (x)
 (vlax-curve-getparamatpoint e x)
 )
ptl
)
 )
 (if (vlax-curve-isclosed e)
(not (equal (reverse pams)
 (cons 1. (cons 0. (cdr il)))
 )
)
(not (equal (vl-remove '0. (reverse pams)) il)) ;_假闭合情况
 )
)
 )
)

ynhh · 发表于 2013-10-31 14:12:13

黄工再看看我那 11 楼，这是我找的与多线相关的程序，不成敬意

;;;****************************************************
;;; No.23-4 返回多段线(*POLYLINE)的所有顶点坐标函数
;;;****************************************************
(defun ayGetPLineVTX (EntName1 / Obj1 vtx vtxlst PtsList i)
(cond
((= (cdr (assoc 0 (entget EntName1))) "LWPOLYLINE")
(setq PtsList (ayGetLWPolyLineVTX EntName1))
);end_switch
((= (cdr (assoc 0 (entget EntName1))) "

OLYLINE")
(setq PtsList (ayGetPolyLineVTX EntName1))
);end_switch
);end_cond
(setq PtsList PtsList)
);end_defun

;;;-----------------------------------------------
;;; No.23-4-1 获取 LWPOLYLINE 对象所有顶点坐标
;;;-----------------------------------------------
(defun ayGetLWPolyLineVTX (EntName1 / Obj1 vtx vtxlst PtsList i)
(vl-load-com)
(setq Obj1 (vlax-ename->vla-object EntName1))
(setq vtx (vla-get-Coordinates Obj1))
(setq vtxLst (vlax-safearray->list (vlax-variant-value vtx)))
(setq i 0)
(setq PtsList nil)
(repeat (/ (length vtxLst) 2)
(setq PtsList (append PtsList (list (list (nth i vtxLst) (nth (1+ i) vtxLst)))))
(setq i (+ i 2))
);end_repeat
(setq PtsList PtsList)
);end_defun

;;;---------------------------------------------
;;; No.23-4-2 获取 POLYLINE 对象所有顶点坐标
;;;---------------------------------------------
(Defun ayGetPolyLineVTX (LwPolyEntName / entData1 entName1 pel ptp wpl wpll plp par ct
pen rl pn clk pt al gx bj np xc gg rr cp retList)
(setq entName1 LwPolyEntName)
(setq retList nil)
(setq entData1 (entget entName1))
(if (= "

OLYLINE" (Cdr (Assoc 0 entData1)))
(progn
(setq pel entData1          ;取出对象表.
      ptp (Cdr (Assoc 70 pel)) ;取出结束片段型.
      wpl '()                ;自建的点位数表.
   wpll '()
   entName1 (EntNext entName1)
   pen entName1
);end_setq
(While (/= "SEQEND" (Cdr (Assoc 0 (entget pen))));如果没束.
   (setq pel (entget pen)             ;取得顶点对象数据表.
         plp (Cdr (Assoc 10 pel))    ;取出控制点点位.
         par (Cdr (Assoc 42 pel))    ;取出弓弦比.
         wpl (Cons (List plp par) wpl) ;将数据加到WPL表中.
      wpll (cons plp wpll)
   );end_setq
   (setq pen (EntNext pen));搜索下一个对象.
);end_while
(setq wpll (Reverse wpll))

;以下代码暂时没有用！
(setq ct (If (= 0 (Cadr (Car wpl))) "直线片段封闭" "弧片段封闭"))
(setq wpl (Cons (Last wpl) wpl);加入封闭点.
      wpl (Reverse wpl)       ;整理WPL表.
      rl (Length wpl)
      pn 0
);end_setq
(setq clk (If (Or (= 0 ptp) (= 128 ptp)) "开口" "封闭"))
(Repeat (1- rl)       ;逐点分析.
   (setq al (Nth pn wpl) ;取出点数据表.
         pt (Car al)    ;取出点位.
   );end_setq
   (If (And (/= 0.0 (Cadr al)) (Nth pn wpl)) ;如果是断.
   (Progn (setq gx (Cadr al)             ;取出弓比.
                  bj (* (ATAN (ABS gx)) 4) ;计算包角.
                  np (Car (Nth (1+ pn) wpl)) ;取出下一点位.
                  xc (* 0.5 (Distance pt np));半弦长计算.
                  gg (* gx xc)             ;弓高计算.
                  rr (/ (+ (* xc xc)(* gg gg)) (* 2 gg))
            );end_setq
            (setq cp (Polar pt (setq pa (Angle pt np)) xc)
                  cp (Polar cp (+ pa (* 0.5 PI)) (- rr gg))
            );end_setq
   );end_progn
   );end_if
   (setq pn (1+ pn))
);end_repeat

(setq retList wpll)
);end_progn
);end_if
);end_defun

;;;88888888888888888888888888
;;;
;;;以下功能测试与上部相同但很简单啊
;;;
;;;88888888888888888888888888

;;;http://hi.baidu.com/123523058/item/7d995410b5506afa9c778ac4
;;;================================
;;;功能：获取多段线顶点列表(未考虑闭合)
(defun PLINE-GETPTLST (EN / LST ENT N)
(setq LST '()
ENT (entget EN)
)
(foreach N ENT
(if (= (car N) 10)
   (setq LST (cons (cdr N) LST))
)
)
;;返回
(reverse LST)
)
;;;================================

(setq ss (ssget))
(setq i 0)
(sslength ss)
(setq ssn (ssname ss i))
(PLINE-GETPTLST SSN)

((2668.14 381.333) (2812.11 555.782) (2849.35 452.435) (2814.6 366.451) (2754.22 306.074))
((2668.14 381.333) (2812.11 555.782) (2849.35 452.435) (2814.6 366.451) (2754.22 306.074))

;;;88888888888888888888888888888888888

返回多段线的各顶点
(vertexs SSN)

说明:
返回多段线的各顶点

函数内容:
(defun vertexs (ename / plist pp n)
(setq obj (vlax-ename->vla-object ename))
(setq plist (vlax-safearray->list
(vlax-variant-value
   (vla-get-coordinates obj))))
(setq n 0)
(repeat (/ (length plist) 2)
   (setq pp (append pp (list (list (nth n plist)(nth (1+ n) plist)))))
   (setq n (+ n 2))
)
pp
)

参数:
ename:图元名

返回值:
各顶点形成的列表

;;;88888888888888888888888888888888888

;;-----------------------------------------------------------------------------------------------------------

;;功能返回多段线各个顶点坐标组成的表

;; ename—图元名 (hj_ddx_pt SSN)

(defun hj_ddx_pt (ename / plist pp n)

(setq obj (vlax-ename->vla-object ename))

(setq plist (vlax-safearray->list (vlax-variant-value (vla-get-coordinates obj))))

(setq n 0)

(repeat (/ (length plist) 2)

   (setq pp (append pp (list (list (nth n plist)(nth (1+ n) plist)))))

   (setq n (+ n 2))

)

pp

)

;;-----------------------------------------------------------------------------------------------------------

;;;88888888888888888888888888888

coordsofsegbypick 返回多义线所点击子段的端点坐标

语法:
(coordsofsegbypick ename p)

说明:
返回多义线所点击子段的端点坐标

函数内容:
(defun coordsofsegbypick (ename p)
(setq obj (vlax-ename->vla-object ename)
      pp (vlax-curve-getclosestpointto obj (trans p 1 0))
         n (fix (vlax-curve-getparamatpoint obj pp)))
(segcoord obj n)
)

参数:
ename:图元名
p:点

返回值:
坐标列表
;;;88888888888888888888888888888
;;-----------------------------------------------------------------------------------------------------------

;;;88888888888888888888888888888
numbersofseg 返回多段线子段的数量

语法:

(numbersofseg SSN);在此返回段数

说明:

返回多段线子段的数量

函数内容:

(defun numbersofseg (ename)

(setq obj (vlax-ename->vla-object ename))

(setq plist (vlax-safearray->list

(vlax-variant-value

   (vla-get-coordinates obj))))

(1- (/ (length plist) 2))

)

参数:

ename:图元名

返回值:

子段数量的整数

;;;88888888888888888888888888888

;;功能返回多段线第n个顶点坐标

;; ename—图元名

;; n—顶点序号

(hj_ddx_n_pt SSN 3)

(defun hj_ddx_n_pt (ename n)

(setq obj (vlax-ename->vla-object ename))

(setq plist (vlax-safearray->list (vlax-variant-value (vla-get-coordinates obj))))

(list (nth (* n 2) plist)(nth (1+ (* n 2)) plist))
)
;;-----------------------------------------------------------------------------------------------------------

;;-----------------------------------------------------------------------------------------------------------
;;;返回多段线第n子段的两个端点坐标函数

;; LwPolyEntName —图元名
(hj_LwPoly_n_pt SSN 3)

(defun hj_LwPoly_n_pt(LwPolyEntName n / Obj Ptlist sPt ePt)

(setq obj (vlax-ename->vla-object LwPolyEntName))

(setq sPt (vlax-safearray->list (vlax-variant-value (vla-get-coordinate obj (- n 1)))))

(setq ePt (vlax-safearray->list (vlax-variant-value (vla-get-coordinate obj n))))

(setq Ptlist (list sPt ePt))

);end_defun
;;-----------------------------------------------------------------------------------------------------------

;;;8888888888888888888888888888888

coodsofsegbynum 返回多段线第n子段的端点坐标

语法:
(coodsofsegbynum obj n)
说明:

返回多段线第n子段的端点坐标
函数内容:

(defun coodsofsegbynum (obj n)
(vlax-safearray->list
            (vlax-variant-value
               (vla-get-coordinate obj 2)))
)
参数:

obj:图元名
n:代表子段位置的整数
返回值:

坐标列表

;;;8888888888888888888888888888888

判断点在多边形的位置之完全版

;判断点在多边形的位置:内、外、线上
;返回值:内:1、外:-1、线上:0
;;方法1----射线法;
;;点是否在多边形内
;;点 P 是否在多边形 PM 内
;;If 'p' is in 'pm', return T.
;;'mx' is a very long distance.
(defun isInorOut (p pm / i p1 p2 tf tf1 tf2 px jp ret)
(setq    px (list (+ 1e+100 (car p)) (cadr p))
p1 (last pm)
i -1
  )

(while (and (not ret)
         (setq p2 (nth (setq i (1+ i)) pm))
   )
   (if    (setq jp (inters px p p1 p2))
   (if (equal (car jp) (car p) 0.0001)
   (setq ret t)
      (setq tf2 (if (> (cadr p1) (cadr p2)) 1 0)
      tf (if (= tf1 tf2) tf (not tf))
      tf1 tf2
      )
   )
   (setq tf1 nil)
   )
   (setq p1 p2)
)

(cond
(ret 0)             ;线上
(tf 1)                ;内
(t -1)                ;外
  )
)

;;方法2---角度法
;;点是否在多边形内
(defun ptinpm (pt lst / i p1 p2 an anl ret)
(setq i -1 p1 (last lst))
(while (and (not ret)
         (setq p2 (nth (setq i (1+ i)) lst))
   )
   (cond
   ((equal p2 pt 1e-4) (setq ret t))
   (t
      (setq an (- (angle pt p1) (angle pt p2)))
      (if (equal pi (abs an) 1e-4)
   (setq ret t)
   (setq anl (cons (rem an PI) anl))
   )
   )
   )
   (setq p1 p2)
)
(cond
(ret 0)             ;线上;
   (t
   (if (equal PI (abs (apply '+ anl)) 1e-4)
      1                ;内;
      -1                ;外;
   )
   )
)
)

;测试

(DEFUN C:tt (/ Curve Pt lst a b c)
(IF (SETQ Curve (CAR (ENTSEL "\n选择一条曲线:")))(progn
   (setq lst (MAPCAR (FUNCTION CDR)
                  (VL-REMOVE-IF (FUNCTION (LAMBDA (x) (/= 10 (CAR x)))) (entget Curve))
               )
   )
   (WHILE (SETQ Pt (GETPOINT "\n点取测试点:"))
   (setq pt (list (car pt) (cadr pt))
      c 1
   )

   (setq a (ptinpm Pt lst))
   (princ "\nxd-point_inm:") (princ (cond ((= 0 a) "线上")
                              ((= 1 a) "内")
                              (t "外")))

   (setq a (xd-point_inm Pt lst))
   (princ "\nptinpm:") (princ (cond ((= 0 a) "线上")
                              ((= 1 a) "内")
                              (t "外")))

   )
))
(PRINC)
)

论坛上的相关判断函数未包含判断点是否在多边形线上
该函数同时判断点在多边形线的位置三种可能：
1. 点在内部；
2. 点在外部；
3. 点在线上。

;;;8888888888888888888888888888888

13648893846 · 发表于 2017-9-19 08:46:07

hehoubin 发表于 2013-11-1 21:47
求这几个黄大侠能不能贴出来呀;;164.31 [功能] 点表生成多段线
;;164.32 [功能] 多段线反向(起点反成终点 ...

能否实现两条点数不同的多段线间平均插入N条多段线

自贡黄明儒 · 发表于 2022-12-24 19:56:44

部分舆全部发表于 2014-11-6 23:14
问下黄老师，首尾相连的多段线如何闭合成封闭的多段线

命令pe？

自贡黄明儒 · 发表于 2013-10-31 09:01:07

占位:示例示例示例

gdslqs · 发表于 2013-10-31 09:13:26

不全啊，老黄

429014673 · 发表于 2013-10-31 12:43:37

自贡黄明儒 · 发表于 2013-10-31 14:25:13

ynhh 发表于 2013-10-31 14:12
黄工再看看我那 11 楼，这是我找的与多线相关的程序，不成敬意

;;;***************************** ...

(defun isInorOut
好象是caoyin的，没有用射线法吧？“射线”是你加的？

ynhh · 发表于 2013-10-31 14:58:55

好象是caoyin的，没有用射线法吧？“射线”是你加的？
你这对些程序的出处都知道是那个写的啊

感觉一些成功的程序，都混杂着多位朋友的才华

这些程序也是从网上找的，不是我加的
你看上就测试收纳啊

hehoubin · 发表于 2013-11-1 21:40:49

学习了。黄大侠，

hehoubin · 发表于 2013-11-1 21:47:14

求这几个黄大侠能不能贴出来呀;;164.31 [功能] 点表生成多段线
;;164.32 [功能] 多段线反向(起点反成终点) byzml84
;;164.33 [功能] 多段线删除顶点
;;164.34 [功能] 多段线增加顶点
;;164.35 [功能] 多段线修改顶点
;;164.36 [功能] 多段线拷贝子段
;;164.37 [功能] 修改多段线子段
;;164.38 [功能] 修改多段线子段为直线

hehoubin · 发表于 2013-11-1 22:02:18

;;164.30 [功能] 构造矩形 by highflybird
;;164.31 [功能] 点表生成多段线
;;164.32 [功能] 多段线反向(起点反成终点) byzml84
;;164.33 [功能] 多段线删除顶点
;;164.34 [功能] 多段线增加顶点
;;164.35 [功能] 多段线修改顶点

求这几个，能否贴出来呀
;;164.36 [功能] 多段线拷贝子段
;;164.37 [功能] 修改多段线子段
;;164.38 [功能] 修改多段线子段为直线

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

[讨论] 关于多段线

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

相关帖子

点评

点评