【e派】工具箱函数再揭秘及应用实例
本帖最后由 xyp1964 于 2017-11-20 22:01 编辑;; 很多函数都是嵌套的，可能部分函数给得不全，就慢慢完善吧……
;; xyp-SubUpd 更改图元DXF组码以修改实体属性 (xyp-SubUpd ename code newvalue)
;|
功能 : 更改图元、图元表、选择集DXF组码以修改实体属性
方式 : (xyp-SubUpd 实体名 DXF码 新值)
实例1 : 改圆半径为500
(xyp-SubUpd (car(entsel"\n选择圆: ")) 40 500)
实例2 : 改文本为"明经通道"
(xyp-SubUpd (car(entsel"\n选择文本: ")) 1 "明经通道")
实例3 : 改块的插入点为(0 0 0)
(xyp-SubUpd (car(entsel"\n选择图块: ")) 10 '(0 0 0))
(xyp-SubUpd (ssget) 62 1)
|;
(defun xyp-SubUpd (ename code val / ent x y i s1)
(cond ((= (type ename) 'ENAME)
(setq ent (entget ename))
(if (and (= (type code) 'LIST) (= (type val) 'LIST))
(mapcar '(lambda (x y) (xyp-SubUpd ename x y)) code val)
(progn
(if (= (xyp-dxf code ename) nil)
(entmod (append ent (list (cons code val))))
(entmod (subst (cons code val) (assoc code ent) ent))
)
(entupd ename)
)
)
)
((= (type ename) 'PICKSET)
(setq i -1)
(while (setq s1 (ssname ename (setq i (1+ i))))
(xyp-SubUpd s1 code val)
)
)
((= (type ename) 'LIST)
(foreach s1 ename (xyp-SubUpd s1 code val))
)
)
ename
)
;;实例：
;; 选择集变红色
(xyp-SubUpd (ssget) 62 1)
;; 批量字高改500
(xyp-SubUpd (ssget '((0 . "text"))) 40 500)
;; 直线起点改到原点
(xyp-SubUpd (ssget '((0 . "line"))) 10 '(0 0 0))
请教院长这个函数xyp-sc能公开吗？
;; xyp-Sort-PList 点集实体排序 (xyp-Sort-Plist lst mode) mode 1~10
(defun xyp-Sort-PList (lst mode / x y)
(defun aaa (lst fun1 fun2 / x y x1 x2 y1 y2)
(vl-sort lst
'(lambda (x y)
(setq x (trans (car x) 0 1)
y (trans (car y) 0 1)
x1 (car x)
x2 (car y)
y1 (cadr x)
y2 (cadr y)
)
(cond ((and (= x1 x2) (= y1 y2) (> (caddr x) (caddr y))) T)
((and (= y1 y2) (fun1 x1 x2)) T)
((fun2 y1 y2) T)
(T nil)
)
)
)
)
(defun bbb (lst fun1 fun2 / x y x1 x2 y1 y2)
(vl-sort lst
'(lambda (x y)
(setq x (trans (car x) 0 1)
y (trans (car y) 0 1)
x1 (car x)
x2 (car y)
y1 (cadr x)
y2 (cadr y)
)
(cond ((and (= x1 x2) (= y1 y2) (> (caddr x) (caddr y))) T)
((and (= x1 x2) (fun1 y1 y2)) T)
((fun2 x1 x2) T)
(T nil)
)
)
)
)
(cond ((= mode 1) (aaa lst < >)) ; 上→下，左→右
((= mode 2) (aaa lst > >)) ; 上→下，右→左
((= mode 3) (aaa lst < <)) ; 下→上，左→右
((= mode 4) (aaa lst > <)) ; 下→上，右→左
((= mode 5) (bbb lst > <)) ; 左→右，上→下
((= mode 6) (bbb lst < <)) ; 左→右，下→上
((= mode 7) (bbb lst > >)) ; 右→左，上→下
((= mode 8) (bbb lst < >)) ; 右→左，下→上
((= mode 9) (vl-sort lst '<)) ; 单一数值从小到大
((= mode 10) (vl-sort lst '>)) ; 单一数值从大到小
)
) 本帖最后由 xyp1964 于 2017-11-20 21:50 编辑
;; 混合文本增减复制
(defun c:test1417 ()
(xyp-CMDLA0)
(setq int (Uint 1 "" "步距" int))
(if (and (setq s1 (car (entsel "\n选择: ")))
(xyp-etype s1 "text")
)
(progn
(setq pt (xyp-9pt s1 5)
lst (xyp-Get-HzEngNum (xyp-DXF 1 s1) 0)
)
(while (setq p1 (getpoint pt "\n基点<退出>: "))
(setq lst (mapcar '(lambda (x)
(cond ((setq a (distof x))
(xyp-2str (+ a int))
)
((setq b (xyp-Get-HzEngNum x 2))
(setq b (vl-string->list (car b))
b (mapcar '(lambda (x) (+ x int)) b)
b (vl-list->string b)
)
)
(t x)
)
)
lst
)
s2(xyp-copymove s1 pt p1)
s2(xyp-SubUpd s2 1 (xyp-strcat lst ""))
)
)
)
)
(xyp-CMDLA1)
)
xyp-get-DXF，有源码了，顶 本帖最后由 xyp1964 于 2017-11-20 22:02 编辑
;; xyp-DXF 实体dxf数据 (xyp-DXF code ename)
(defun xyp-DXF (code ename / ent lst a)
(if (= (type code) 'LIST)
(progn
(setq ent (entget ename)
lst'()
)
(foreach a code
(setq lst (cons (list a (cdr (assoc a ent))) lst))
)
(reverse lst)
)
(if (= code -3)
(cdr (assoc code (entget ename '("*"))))
(cdr (assoc code (entget ename)))
)
)
)
来顶一下，这次真的是源码 无条件顶，院长的源码那是必须学习滴 翻了个出来，这也是院长的么？
(defun sub_upd (ename code newvalue)
(entmod (subst (cons code newvalue)
(assoc code (entget ename))
(entget ename)
)
)
(entupd ename)
) 本帖最后由 xyp1964 于 2017-11-20 22:02 编辑
;; xyp-Put VL方式修改 (xyp-Put keyname ename value)
(defun xyp-Put (keyname ename value / obj i s1)
(cond ((= (type ename) 'ENAME)
(setq obj (vlax-ename->vla-object ename))
((eval (read (strcat "vla-put-" keyname))) obj value)
(vla-update obj)
)
((= (type ename) 'PICKSET)
(setq i -1)
(while (setq s1 (ssname ename (setq i (1+ i))))
(setq obj (vlax-ename->vla-object s1))
((eval (read (strcat "vla-put-" keyname))) obj value)
(vla-update obj)
)
)
((= (type ename) 'LIST)
(foreach x ename (xyp-Put keyname x value))
)
)
)
;; 实例
;; 选择集改红色
(xyp-Put "color" (ssget) 1)
xyp1964 发表于 2012-7-21 01:51 static/image/common/back.gif
能打个包不？ 本帖最后由 xyp1964 于 2017-11-20 22:03 编辑
;; CheckPtn 删除重复点表 (CheckPtn ptn 500)
(defun CheckPtn (ptn fuzz / lst p1 lst-t pt)
(setq lst '())
(while (>= (length ptn) 2)
(setq p1 (car ptn)
ptn (cdr ptn)
lst (cons p1 lst)
lst-t '()
)
(foreach pt ptn
(if (>= (distance p1 pt) fuzz)
(setq lst-t (cons pt lst-t))
)
)
(setq ptn (reverse lst-t))
)
lst
)
好代码，谢谢院长 支持院长