【e派】工具箱函数再揭秘及应用实例

1993063 · 发表于 2012-7-21 09:54:44

好代码

，谢谢院长

preone · 发表于 2012-7-21 09:59:30

这个，必须好好学习~~

teykmcqh · 发表于 2012-7-21 10:07:31

院长真是大师风范啊！

xyp1964 · 发表于 2012-7-21 10:20:58

本帖最后由 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
)

小菜123 · 发表于 2012-7-21 11:18:02

请问院长是哪个院的？

xyz2009xyz · 发表于 2012-7-21 11:24:02

见到院长放源码肯定得支持，用过院长几个函数，相当不错的！可是工具箱一直没用，CAD用的不是很多，为一两各功能，不习惯加载这么大一个工具箱！

x_s_s_1 · 发表于 2012-7-21 11:24:50

本帖最后由 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 值不对，函数没问题，不好意思

czykx613 · 发表于 2012-7-21 11:45:58

希望有更多的源代码及使用图片。

机械工程师 · 发表于 2012-7-21 12:56:38

支持院长。

xyp1964 · 发表于 2012-7-21 13:25:25

本帖最后由 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))
)

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

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

[讨论] 【e派】工具箱函数再揭秘及应用实例

点评