本帖最后由 nzl1116 于 2014-6-21 14:58 编辑
获取外观交点,如果存在节点交叉共线的,要先移除多余的节点。
- (defun GetPts (Lst)
- (if (caddr Lst)
- (cons
- (list (car Lst) (cadr Lst) (caddr Lst))
- (GetPts (cdddr Lst))
- )
- )
- )
- (defun intersectPts (vlaobj1 vlaobj2 / ptsVar ptsArray ptsList)
- (setq ptsVar (vla-intersectwith vlaobj1 vlaobj2 acExtendNone)
- ptsArray (vlax-variant-value ptsVar)
- ptsList (vl-catch-all-apply 'vlax-safeArray->list (list ptsArray))
- )
- (if (vl-catch-all-error-p ptsList)
- nil
- (GetPts ptsList)
- )
- )
- (defun RemoveParam (EndPrm Pline / SomPrm)
- (cond ((= EndPrm 0) nil)
- ((= (setq SomPrm (vlax-curve-GetParamAtPoint Pline (vlax-curve-GetPointAtParam Pline EndPrm))) EndPrm)
- (RemoveParam (1- EndPrm) Pline)
- )
- ((/= SomPrm EndPrm)
- (cons SomPrm (RemoveParam (1- EndPrm) Pline))
- )
- )
- )
- (defun GetSelfInters (Ename / VlaObj PrmLst EndPrm)
- (setq VlaObj (vlax-ename->vla-object Ename))
- (setq EndPrm (vlax-curve-GetEndParam VlaObj))
- (if (= (vlax-curve-GetParamAtPoint VlaObj (vlax-curve-GetPointAtParam VlaObj EndPrm)) 0)
- (setq EndPrm (1- EndPrm))
- )
- (setq PrmLst (append
- (vl-remove-if
- (function (lambda (x) (= (fix x) x)))
- (mapcar
- (function
- (lambda (y)
- (vlax-curve-GetParamAtPoint VlaObj y)
- )
- )
- (intersectPts VlaObj VlaObj)
- )
- )
- (mapcar 'fix (RemoveParam EndPrm VlaObj))
- )
- )
- (mapcar (function (lambda (x) (vlax-curve-GetPointAtParam VlaObj x)))
- (vl-sort PrmLst '<)
- )
- )
|