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

xyp1964 · 发表于 2012-7-21 01:18

本帖最后由 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 更改图元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))

adc · 发表于 2012-8-22 20:10

请教院长这个函数xyp-sc能公开吗？

xyp1964 · 发表于 2018-11-16 20:59

;; 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 '>)) ; 单一数值从大到小
)
)

;; 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 · 发表于 2013-11-15 08:45

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

;; 混合文本增减复制 
(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) 
)

baiyier1112 · 发表于 2013-4-19 23:29

xyp-get-DXF，有源码了，顶

xyp1964 · 发表于 2012-7-21 01:23

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

cnks · 发表于 2012-7-21 01:32

来顶一下，这次真的是源码

yjr111 · 发表于 2012-7-21 01:36

无条件顶，院长的源码那是必须学习滴

cnks · 发表于 2012-7-21 01:41

翻了个出来，这也是院长的么？

(defun sub_upd (ename code newvalue)
  (entmod (subst (cons code newvalue)
   (assoc code (entget ename))
   (entget ename)
   )
  )
  (entupd ename)
)

xyp1964 · 发表于 2012-7-21 01:51

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

cnks · 发表于 2012-7-21 01:55

xyp1964 发表于 2012-7-21 01:51

能打个包不？

xyp1964 · 发表于 2012-7-21 02:44

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

x_s_s_1 · 发表于 2012-7-21 05:14

好代码，谢谢院长

仲文玉 · 发表于 2012-7-21 05:31

支持院长

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

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

本帖子中包含更多资源

点评

评分

本帖被以下淘专辑推荐:

相关帖子

点评

本帖子中包含更多资源

点评

点评

点评

点评

评分

点评

点评

评分