【函数分享】最近无聊写的一些函数，也许对新人有帮助！
最近无聊写的一些函数。对新人也许有帮助！ 函数大都没怎么测试，仅供参考;============{ 在指定位置删除或插入元素 }===============;nil表示要删除。如果有值为要插入的元素---by wowan1314
;(t11 '(1 2 3 4 5 6) 2 0);;->(1 2 0 3 4 5 6)
;(t11 '(1 2 3 4 5 6) 2 nil);;->(1 2 4 5 6)
;2013年7月20日 星期六
(defun t11 (lst pos mod / qlst a hlst)
(setq a -1)
(setq hlst (vl-member-if-not
'(lambda(x)
(setq a (1+ a))
(if (= a pos) nil
(setq qlst (cons x qlst))
)
)
lst
)
)
(if mod
(apply 'append (list (reverse(cons mod qlst)) hlst))
(apply 'append (list (reverse qlst) (cdr hlst))
)
)
)
;按新的点对表修改组码表更新图元
(defun t1 (en xin / enb)
(setq enb (entget en))
(mapcar '(lambda(x)
(entmod(subst x (assoc (car x) enb)enb))
)
xin
)
)
;表中两个两个配对后的表
(defun t3 (lst / a)
(setq a 0)
(vl-remove-if '(lambda(x)(= (rem (setq a (1+ a))2)0))
(mapcar 'cons lst (cdr lst))
)
)
;得到表的奇偶项
;(T2 LST T)奇数项。(T2 LST NIL)为偶数
(defun t2 (lst b / a)
(setq a 0
c '(lambda(x)(= (rem (setq a (1+ a))2)0))
)
(if b
(vl-remove-if c lst)
(vl-remove-if-not c lst)
)
)
;选择集变图元名表
(defun t1 (ss)
(cdr(reverse(mapcar 'cadr (ssnamex (ssget))
)
)
)
)
;选择集变图元名表
(defun t2 (ss / a en lst)
(setq a -1)
(while (setq en (ssname ss (setq a (1+ a))
)
)
(setq lst (cons en lst))
)
lst
)
;图元名表变选择集
(defun t3 (lst / ss)
(setq ss (ssadd))
(mapcar '(lambda(x)(setq ss (ssaddx ss)))lst)
ss
)
;dxf_read 按值或值表读取组码表
(defun dxf_read (a en / enb)
(setq enb (entget en))
(if (= 'list (type a))
(mapcar '(lambda(x)(cdr(assoc x enb))) a)
(cdr(assoc a enb))
)
)
;单个图元包围盒
(defun enbox (ename / ll ur)
(vla-getboundingbox (vlax-ename->vla-object ename) 'll 'ur)
(mapcar 'vlax-safearray->list (list ll ur))
)
;选择集包围盒1
(defun t12 (ss / enma enmi a en ll ur)
(setq a -1)
(while
(setq en (ssname ss (setq a (1+ a))
)
)
(setq entb (enbox en)
enma (cons (car entb) enma)
enmi (cons (cadr entb) enmi)
)
)
(mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(max min) (list enma enmi))
)
;选择集包围盒2
(defun t11 (ss / a en enma enmi ll ur)
(setq a -1)
(while
(setq en (ssname ss (setq a (1+ a))
)
)
(vla-getboundingbox (vlax-ename->vla-object en) 'll 'ur)
(setq enma (cons (vlax-safearray->list ll) enma)
enmi (cons (vlax-safearray->list ur) enmi)
)
)
(mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(max min) (list enma enmi))
)
;图元名表包围盒
(defun t13 (sslst / enma enmi ll ur)
(mapcar
'(lambda(x)
(vla-getboundingbox (vlax-ename->vla-object x) 'll 'ur)
(setq enma (cons (vlax-safearray->list ll) enma)
enmi (cons (vlax-safearray->list ur) enmi)
)
)
sslst
)
(mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(max min) (list enma enmi))
)
;按分隔符分解字符串成表.
(defun t11 (str del / pos lst)
(while
(setq pos (vl-string-search del str))
(setq lst (cons (substr str 1 pos) lst)
str (substr str (+ 1 pos (strlen del))
)
)
)
(reverse(cons str lst))
)
;三点求圆弧圆心半径
(defun yy-3arc (p1 p2 p3 / z1 z2 yxin)
(setq z1 (car (yy-np1p2 p1 p2 2))
z2 (car (yy-np1p2 p1 p3 2))
)
(if
(setq yxin (inters
z1 (polar z1 (+ (angle p1 p2)(* pi 0.5)) 0.1)
z2 (polar z2 (+ (angle p1 p3)(* pi 0.5)) 0.1)
nil
)
)
(list yxin (distance yxin p1))
)
)
;删除相应组码
(defun t1 (lst1 lst)
(vl-remove-if '(lambda(x)(member x lst1)) lst)
)
;删除相应组码只删第一个
(defun t2 (lst1 lst / lst2)
(vl-remove-if '(lambda(x)
(if
(and(member x lst1)(not(member x lst2))
)
(setq lst2 (cons x lst2))
)
)
lst
)
)
;替换组码表，如果没有就加到最后
(defun t3 (lst1 lst / old)
(mapcar
'(lambda(x)
(if (setq old (assoc (car x) lst))
(setq lst (subst x old lst))
(setq lst (cons x (reverse lst))
)
)
)
lst1
)
lst
)
;从指定位置a截取指定长度b的表
(defun t4 (lst a b / i c xlst)
(setq i -1 c (1-(+ a b))
)
(vl-member-if
'(lambda(x)
(setq i (1+ i))
(if (<= a i c)
(setq xlst (cons x xlst))
)
(if (> i c)
t
)
)
lst
)
xlst
)
;分解表内套的表
(defun t5 (lst )
(mapcar '(lambda(x)(if (listp x)(setq lst2 (t5 x))(setq lst2 (cons x lst2))))lst)
lst2
)
;;消除字符串中的空格
(defun t11 (str)
(apply
'strcat
(mapcar
'vl-princ-to-string
(read
(strcat "(" str ")")
)
)
)
)
;;消除字符串中的空格
(defun t12 (str)
(while
(> (strlen str)
(strlen
(setq str (vl-string-subst "" " " str))
)
)
)
str
)
;求字符串表 或 数表中 最大的数 或最长的字符串
(defun t11 (lst)
(if (= (type (car lst)) 'str)
(cdr
(assoc
(apply
'max
(mapcar
'(lambda(x)
(strlen x)
)
lst
)
)
(mapcar
'(lambda(x)
(list (strlen x) x)
)
lst
)
)
)
(apply 'max lst)
)
)
;图元之后所有图元组成的选择集
(defun t12 (en / ss)
(setq ss (ssadd))
(while
(setq en (entnext en))
(if (member
(cdr (assoc 0 (entget en))
)
'("attrib" "vertex" "seqend")
)
nil
(setq ss (ssadd en ss))
)
)
ss
)
;;图元之后所有图元的表
(defun t11 (en / lst)
(while
(setq en (entnext en))
(if (member
(cdr (assoc 0 (entget en))
)
'("attrib" "vertex" "seqend")
)
nil
(setq lst (cons en lst))
)
)
lst
)
;将字符串表合并为按指定分隔符分隔的字符串
; (t11 '("1" "2" "3" "4" "5" "6") ":")
;==> "1:2:3:4:5:6"
(defun t11 (lst del / ss lst p1 p2 p3)
(vl-string-right-trim
del
(eval
(cons 'strcat
(mapcar
'(lambda(x)
(strcat x del)
)
lst
)
)
)
)
)
; (t11 '("1" "2" "3" "4" "5" "6") ":")
;==> "1:2:3:4:5:6"
(defun t11 (lst del)
(vl-string-right-trim
del
(apply
'strcat
(mapcar
'(lambda
(
x
)
(strcat
x
del
)
)
lst
)
)
)
)
;计算点集中距离原点 （最大 最小）
(defun t11 (plst)
(setq lst (vl-sort lst '(lambda(a b) (> (distance a '(0 0 0)) (distance b '(0 0 0)) ))
)
)
(list (car lst)(last lst))
)
;计算点集围成的包围盒的 对角点
(defun t12 (plst)
(mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(min max) (list lst lst))
)
;计算实数表中 最大 最小值
(defun t13 (plst)
(mapcar '(lambda(a b)(apply 'mapcar (cons a b))) '(min max) (list lst lst))
)
;;等分表，没考虑表的顺序。
(defun t1 (n lst / a ll zll)
(setq a 1)
(mapcar
'(lambda(x)
(if (< a n)
(setq ll (cons x ll) a (1+ a))
(setq zll (cons (cons x a) zll)
ll nil
a 1
)
)
)
lst
)
(if ll (cons ll zll) zll)
)
;;用新项替换表中的旧项，只替换第一个。
(defun t2 (new old lst)
(read(apply 'vl-string-subst (mapcar 'vl-princ-to-string (list new old lst)))
)
)
;;点集按pl线的pl起点到点到曲线的最近点的距离排序
;;pl为vla实体. 返回排序后的点表
(defun t11 (pl pts)
(mapcar
'cadr
(vl-sort
(mapcar
'(lambda (x)
(list (vlax-curve-getdistatpoint
pl
(vlax-curve-getclosestpointto pl x)
)
x
)
)
pts
)
'(lambda (a b)
(< (car a) (car b))
)
)
)
)
;;得到表中重复次数 及 删除重复后的表
;; (t1 '(1 2 1 2 (1 1) (1 2) (1 2) 1 2))
(defun t1 (lst / lst1 lst2)
(mapcar
'(lambda(x)
(if (member x lst2)
(setq lst1 (cons x lst1))
(setq lst2 (cons x lst2))
)
)
lst
)
(list (length lst1) lst2)
)
;vl-position返回第一个元素出现的索引位置
;这个函数返回元素出现的所有索引位置
(defun t11 (at lst / a nlst)
(setq a 0)
(mapcar '(lambda(x)(and(eq x at)(setq nlst(cons a nlst)))(setq a(1+ a))) lst)
(reverse nlst)
)
;TEXT的四个交点坐标
(defun t11 (ent / p0 p12 ang lst)
(setq ent (entget ent)
p0 (cdr (assoc 10 ent))
ang (cdr (assoc 50 ent))
p12 (textbox ent)
lst
(list
(car p12)
(list (caar p12)(cadadr p12))
(cadr p12)
(list (caadr p12)(cadar p12))
)
)
(mapcar '(lambda(x)(polar p0 (+ ang (angle '(0 0) x)) (distance '(0 0) x))) lst)
)
;得到文字内容
(defun gps->txt-getvalue1 (ename)
(cdr(assoc 1 (entget enmae))
)
)
;设置文字内容
(defun gps->txt-setvalue1 (ename val)
(entmod(subst (cons 1 val)(assoc 1 (entget enmae)) (entget enmae))
)
)
; 得到带数字后缀的字符串的 (文字前缀、数字后缀、小数点位数)
(defun t11 (txt1 / nums lop a1 txt len a2)
(setq nums '(49 50 51 52 53 54 55 56 57 48 43 45 46)
lop t
a1 0
txt (reverse(vl-string->list txt1))
)
(while lop
(if (member (car txt) nums)
(progn
(if (= (car txt) 46) (setq a2 a1))
(setq a1 (1+ a1) txt (cdr txt))
)
(setq lop nil)
)
)
(if (/= a1 0)
(progn
(setq len (- (strlen txt1) a1))
(list (substr txt1 1 len) (substr txt1 (1+ len)) a2)
)
)
)
;;提取属性块指定属性值
;(T12 '("日期" "你妈" "项目负责人") EN)
;用vla-GetAttributes
;(vlax-safearray->list(vlax-variant-value(vla-GetAttributes (vlax-ename->vla-object (car(entsel))))))
(defun t12 (lst en / att atlst)
;(if (= :vlax-true (vla-get-hasattributes VLA)) );检查EN合法性
(setq
att
(mapcar
'(lambda(x)
(cons (vla-get-tagstring x)(vla-get-textstring x))
)
(vlax-invoke (vlax-ename->vla-object en) 'getattributes)
)
atlst
(cons
(apply
'list
(mapcar
'(lambda(x)
(assoc x att)
)
lst
)
)
atlst
)
)
)
;图签为属性块的提取目录程序
(defun c:t11 (/ ss a en att th tm mllst)
(setq ss (ssget '((0 . "INSERT") (66 . 1))) a -1);选中属性块，可再加块名区别
(if ss
(while (setq en (ssname ss (setq a (1+ a))
)
)
(setq
att
(mapcar
'(lambda(x) (cons (vla-get-tagstring x)(vla-get-textstring x))
)
(vlax-invoke (vlax-ename->vla-object en) 'getattributes)
)
)
(if (and (setq th(assoc "图号" att))(setq tm(assoc "图名" att))
)
(setq mllst (cons (cons th tm) mllst))
)
)
)
;(if mllst (排序后写出目录))
)
;;=============={ 返回表m-n之间的所有元素 }===============
;;测试: (T66 3 5 '(2334 556 33 44 66 77 22))==> (33 44 66)
(defun t66 (n m lst / a lst1)
(setq a 0)
(vl-member-if
'(lambda(x) (if (<= n (setq a (1+ a)) m)
(setq lst1 (cons x lst1))
)
(if (> a m) t)
)
lst
)
(reverse lst1)
)
;;=============={ 返回表第N个元素之后的所有元素 }=================
;;测试: (T6 3 '(2334 556 33 44 66 77 22))==> (44 66 77 22)
(defun t6 (n lst / a nlst l)
(setq a 0 l (length lst))
(if (< n (* l 0.65))
(setq nlst (vl-member-if '(lambda(x)(setq a (1+ a)) (< n a) ) lst))
(vl-member-if '(lambda(x)(setq l (1- l) nlst (cons x nlst)) (<= l n) ) (reverse lst))
)
nlst
)
感谢wowan1314 分享函数 我表示，非常有帮助！谢谢 这么多的函数，支持一下 本帖最后由 wowan1314 于 2014-7-24 20:51 编辑
坐个沙发！ 说不定继续无聊呢！;;表内项重复统计---非点表
(defun t11 (lst / a b l)
(while lst
(setq a(car lst)b(length lst)lst(vl-remove a lst)
l(cons(list a(- b(length lst)))l)
)
)
)
;;表内项重复统计---点表
(defun t12 (lst / a b l)
(while lst
(setq a(car lst)lst(mapcar '(lambda(x)(if(equal x a 1e-5)1 x))lst)
b(length lst)lst(vl-remove 1 lst)l(cons(list a(- b(length lst)))l)
)
)
)(defun c:t11 nil
(mapcar''((x)
(mapcar''((x)
(mapcar''((y)(vl-cmdf ".break" y "f" x "@"))
(cdr(reverse(mapcar 'cadr (ssnamex (ssget "_c" x x)))))
)
)
x
)
)
(mapcar''((x)(list (vlax-curve-getendpoint x)(vlax-curve-getstartpoint x)))
('((x)(if (= 1 (length x))x(cdr(reverse x))))
(mapcar 'cadr (ssnamex (ssget '((0 . "L*LINE")))))
)
)
)
);;构建锁定图层过滤表
(defun t11 ( / lays lst)
(setq lst (list (cons -4 "OR>"))
lays (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
)
(vlax-map-collection
lays
'(lambda (x)
(if (= (vla-get-lock x) :vlax-true)
nil
(setq lst (cons (cons 8 (vla-get-name x)) lst))
)
)
)
(cons (cons -4 "<OR") lst)
)
;;构建锁定图层过滤表
(defun t12 ( / lay lst)
(setq lay (tblnext "LAYER" t))
(if (= (cdr (assoc 70 lay)) 0)
(setq lst (list (cons 8 (cdr(assoc 2 lay))) (cons -4 "OR>")))
(setq lst (list (cons -4 "OR>")))
)
(while (setq lay (tblnext "LAYER"))
(if (= (cdr (assoc 70 lay)) 0)
(setq lst (cons (cons 8 (cdr(assoc 2 lay))) lst))
)
)
(cons (cons -4 "<OR") lst)
);;CAD2004得到填充面积（CAD06以上版本 已经有面积的属性了）
(defun c:t11 (/ e s)
(if (setq e (entget(car(entsel))
)
)
(progn
(setq s (cdr(reverse(mapcar 'cdr (cdr(vl-remove-if '(lambda(x)(/= 10 (car x)))e))
)
)
)
)
(apply 'command (cons "pline" s))(command "C")
(rtos (vla-get-area(vlax-ename->vla-object(entlast)))2))
)
);;多段线顶点表
(defun t1 (e)
(mapcar
'cdr(vl-remove-if
'(lambda(x)(/= (car x) 10))
(entget e)
)
)
)
;;包围盒四角点坐标(左下逆时针)
(defun t2 (e / ll ur p2 p4)
(vla-getboundingbox (vlax-ename->vla-object e) 'll 'ur)
(setq ll(mapcar 'vlax-safearray->list (list ll ur))
p2 (list (caadr ll) (cadar ll))
p4 (list (caar ll) (cadadr ll))
)
(list (car ll) p2 (cadr ll) p4)
);求表的交集(t1 (list l1 l2 . . .))
(defun t1 (lst)
(setq l1 (car lst) ll (cdr lst))
(mapcar
'(lambda(a)
(mapcar
'(lambda(b)
(if (member b a) nil (setq l1 (vl-remove b l1))
)
)
l1
)
)
ll
)
l1
);;变量监视用以简单的定位函数出错的位置.;;变量监视函数，如果出错。则输出->出错信息及各变量的赋值情况。
;;用法 在程序开始处(aa:ever-err '(各个变量名。。))即可.
;;程序不出错就没有变量赋值情况。
(defun aa:ever-err (lst )
(setq *olderr* *error* *error* aa:evererr1 *监视变量表* lst)
)
(defun aa:evererr1 (x )
(princ x)
(aa:ever-err2 *监视变量表*)
(setq *error* *olderr* *olderr* nil *监视变量表* nil)
)
(defun aa:ever-err2 (*监视变量表*)
(mapcar
'(lambda(e1 e2)
(princ (strcat "\n" e1 " = "))
(prin1 (eval e2))
)
(mapcar 'vl-princ-to-string *监视变量表*)
*监视变量表*
)
)
;; 1/监视变量
(defun c:t11 ( / a b c d e f)
(aa:ever-err '(a b c d e f))
(setq a 1 b 2 c "3" d 4 e 5 )
(exit)
(setq f '(1 2 34))
)(defun c:t11 (/ PP P1 P2 SS EN ENO I A)
(princ "\n选择矩形")
(setq ss (ssget ":l:s" '((0 . "*lwpolyline"))))
(if ss
(progn
(setq i -1)
(while (setq en (ssname ss (setq i (1+ i))))
(vla-offset (vlax-ename->vla-object en) 100)
(setq eno (entlast)
A 1
)
(repeat 2
(set (read (strcat "P" (itoa A)))
(mapcar 'cdr
(vl-remove-if
'(lambda (b)
(/= (car b) 10)
)
(entget (if (= A 1)
en
eno
)
)
)
)
)
(setq A (1+ A))
)
(mapcar
'(lambda (a b)
(entmake (list '(0 . "line") (cons 10 a) (cons 11 b)))
)
P1
P2
)
)
)
)
(princ)
);;标注的两边长
(defun c:t11 nil
(mapcar
'(lambda(x)
(entmake
(list '(0 . "DIMENSION") '(100 . "AcDbEntity") '(100 . "AcDbDimension")
(cons 10 (car x))
'(70 . 33) '(1 . "") '(100 . "AcDbAlignedDimension")
(cons 13 (car x)) (cons 14 (cadr x))
)
)
(entmake
(list '(0 . "DIMENSION") '(100 . "AcDbEntity") '(100 . "AcDbDimension")
(cons 10 (cadr x))
'(70 . 33) '(1 . "") '(100 . "AcDbAlignedDimension")
(cons 13 (cadr x)) (cons 14 (caddr x))
)
)
)
(mapcar
'(lambda(a)
(mapcar 'cdr
(vl-remove-if
'(lambda (b)
(/= (car b) 10)
)
(entget a)
)
)
)
(vl-remove-if-not
'(lambda(c) (= (type c) 'ename))
(mapcar
'cadr
(ssnamex (ssget '((0 . "LWPOLYLINE")(70 . 1))
)
)
)
)
)
)
) 顶楼主 希望继续无聊 真无聊 支持一个，希望楼主继续无聊 顶顶更健康 感谢wowan1314 分享函数! 纯学习看看，