好代码，谢谢院长
这个，必须好好学习~~
院长真是大师风范啊！
本帖最后由 xyp1964 于 2020-11-19 23:31 编辑
;; xyp-CheckPtn 点表集含fuzz的处理 (xyp-CheckPtn ptn fuzz mode) mode:>=<等
;; 删除重复点 (xyp-CheckPtn ptn fuzz >=)
;; 删除范围外点 (xyp-CheckPtn ptn fuzz <)
(defun xyp-CheckPtn (ptn fuzz mode / lst p1 lst-t pt)
(setq lst '())
(while (>= (length ptn) 1)
(setq p1 (car ptn)
ptn (cdr ptn)
lst (cons p1 lst)
lst-t '()
)
(foreach pt ptn
(if (mode (distance p1 pt) fuzz)
(setq lst-t (cons pt lst-t))
)
)
(setq ptn (reverse lst-t))
)
lst
)
请问院长是哪个院的？
见到院长放源码肯定得支持，用过院长几个函数，相当不错的！可是工具箱一直没用，CAD用的不是很多，为一两各功能，不习惯加载这么大一个工具箱！
本帖最后由 x_s_s_1 于 2012-7-21 12:42 编辑
对于xyp-SubUpd 函数的测试，
(setq ss (ssget '((0 . "line"))))
(repeat (sslength SS) (setq i 0 lst (cons (ssname ss i)lst) i (1+ i)))
(mapcar '(lambda (x)(xyp-SubUpd x 62 1)) lst)
以上代码只可对第一个图元起作用，但是
(xyp-SubUpd ss 62 1)可对全部图元起作用，请院长讲解一下，谢谢
经查，我的那个repeat用错了，lst 值不对，函数没问题，不好意思
希望有更多的源代码及使用图片。
支持院长。
本帖最后由 xyp1964 于 2020-11-19 23:32 编辑
;; xyp-get-Vertexs多义线顶点集
;; (setq ptn (xyp-get-Vertexs ename mode))
;; mode:
;; 0 T nil 所有顶点
;; 1不含重复顶点
;; 2不含直线段中间顶点
;; 3不含封闭直线段中间顶点
(defun xyp-get-Vertexs (ename mode / ptn i pt0 j ac pte pts et pt10 pt1 pt2 pt3)
(cond ((xyp-etype ename "*polyline")
(setq ptn (xyp-get-Coordinates ename))
)
((xyp-etype ename "line,arc")
(setq ptn (list (vlax-curve-getstartPoint ename)
(vlax-curve-getendPoint ename)
)
)
)
((xyp-etype ename "spline")
(setq ptn '()
et(entget ename)
)
(while (or (setq ac (assoc 11 et))
(setq ac (assoc 10 et))
)
;;11 拟合点 10 控制点 均在 WCS 中
(setq et (member ac et)
pt10 (cdr (car et))
et (cdr et)
ptn(cons pt10 ptn)
)
)
(setq ptn (reverse ptn))
)
)
(cond ((= mode 0) (princ));所有点
((= mode 1) ;取消0长线段的角点
(setq ptn (xyp-Ptlst-Test ptn))
)
;;取消0长线段的角点，删除多段线中直线段上的多余节点
((= mode 2)
(setq ptn (xyp-Ptlst-Test ptn)
ptn (xyp-get-VertexsTrue ptn)
)
)
;;取消0长线段的角点，删除多段线中直线段上的多余节点，如果原线闭合或首尾相连判断首尾部分是否直线
((= mode 3)
(setq ptn (xyp-Ptlst-Test ptn)
ptn (xyp-get-VertexsTrue ptn)
pt1 (nth 0 ptn)
pt2 (last ptn)
pt3 (nth (- (length ptn) 2) ptn)
)
(while (< (abs (- (angle pt1 pt2) (angle pt2 pt3))) 1e-4)
(setq ptn (vl-remove pt2 ptn)
pt1 (nth 0 ptn)
pt2 (last ptn)
pt3 (nth (- (length ptn) 2) ptn)
)
)
(setq pt2 (nth 0 ptn)
pt1 (nth 1 ptn)
pt3 (last ptn)
)
(while (< (abs (- (angle pt1 pt2) (angle pt2 pt3))) 1e-4)
(setq ptn (vl-remove pt2 ptn)
pt2 (nth 0 ptn)
pt1 (nth 1 ptn)
pt3 (last ptn)
)
)
)
((or (= mode nil) T) (princ))
)
ptn
)
;; xyp-E2O 将 AutoLISP 类型的对象名转换为 VLA 对象 ename为实体名称 = (car(entsel))
(defun xyp-E2O (ename) (vlax-ename->vla-object ename))
(defun xyp-O2E (oname) (vlax-vla-object->ename oname))
;; xyp-get-VertexsTrue 删除多段线中直线段上的多余节点
(defun xyp-get-VertexsTrue (ptn / ptn1 p1 p2 p3)
(setq ptn1 '())
(while (>= (length ptn) 3)
(setq p1 (nth 0 ptn)
p2 (nth 1 ptn)
p3 (nth 2 ptn)
)
(if (< (abs (- (angle p1 p2) (angle p2 p3))) 1e-6)
(setq ptn (vl-remove p2 ptn))
(setq ptn1 (cons (car ptn) ptn1)
ptn(cdr ptn)
)
)
)
(append (reverse ptn1) ptn)
)
;; xyp-Ptlst-Test 取消0长线段的角点 (xyp-Ptlst-Test ptn)
(defun xyp-Ptlst-Test (ptn / i p0 p1 tmp)
(setq i 0
p0(car ptn)
tmp (list p0)
)
(while (setq p1 (nth (setq i (1+ i)) ptn))
(if (not (equal p1 p0 1e-5))
(setq tmp (cons p1 tmp)
p0 p1
)
)
)
(reverse tmp)
)
;; xyp-List-Div 拆分表 (xyp-List-Div plist 子表数量)
;; (xyp-List-Div '(0 1 2 3 4 5 6 7 8 9) 3)→((0 1 2) (3 4 5) (6 7 8) (9))
(defun xyp-List-Div (lst num / ptn1 ptn2)
(while (> (length lst) num)
(repeat num
(setq ptn1 (cons (car lst) ptn1)
lst(cdr lst)
)
)
(setq ptn2 (cons (reverse ptn1) ptn2)
ptn1 '()
)
)
(if (>= (length lst) 1)
(setq ptn2 (cons lst ptn2))
)
(reverse ptn2)
)
;; xyp-get-LispValue vl数据列表 (xyp-get-LispValue safearray)
(defun xyp-get-LispValue (Value)
(vlax-safearray->list (vlax-variant-value Value))
)
;; xyp-get-Coordinates mesh或pl实体顶点表 (xyp-get-Coordinates ename)
(defun xyp-get-Coordinates (ename / ob ptn lst n)
(setq ob(xyp-e2o ename)
ptn (vla-get-Coordinates ob)
lst '("AcDbPolygonMesh" "AcDbPolyFaceMesh" "AcDb3DPoly" "AcDbLeader" "AcDbPoint" "AcDbSolid" "AcDbTrace" "AcDb2dPolyline" "AcDb3dPolyline")
n (if (member (vla-get-objectname ob) lst)
3
2
)
)
(XYP-LIST-DIV (xyp-Get-LispValue ptn) n)
)
;; xyp-Etype 检查实体类型 (xyp-Etype ename etype)
(defun xyp-Etype (ename etype)
(wcmatch (xyp-get-dxf 0 ename) (strcase etype))
)