【分享明经——发程序、拜新年专贴】

jxlsp

;求多边形顶点列表((x1 y1)(x2 y2)(x3 y3)...)面积  
(defun  lstMJ(lst / x y)
   (abs
     (apply '+
       (mapcar '(lambda(x y)
         (/(-(*(car x)(cadr y))(*(car y)(cadr x)))2.0)
         )  
        (reverse(cdr(reverse(cons(last lst) lst))))
        lst
       )
     )
   )
)

liminnet

caoyin大哥，你二十九楼的程序怎么你不给这个函数我啊，我现在运行起来差了一个

no function definition: VLA-OBJECT->ENAME

caoyin

网站的网页程序的关系，直接复制代码有问题

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=74564

jxphklibin

贴一个我最新写的函数，希望版主加分^_^：
从列表中移去指定的元素（一个不留，支持任意嵌套表）

3. ;;; ============================================================================;;
4. ;;; 函数名：         ;;
5. ;;; RemoveItem         ;;
6. ;;; 从列表中移去指定的元素（一个不留，支持任意嵌套表）    ;;
7. ;;; 参数：         ;;
8. ;;; 要从列表中移去的元素和一个列表      ;;
9. ;;; 示例：         ;;
10. ;;; (RemoveItem nil (list 121 nil (list "abc" nil "dde" nil 111) "aaa" nil 999));;
11. ;;; -> (121 ("abc" "dde" 111) "aaa" 999)     ;;
12. ;;; By 木子CAD工具 小李子  2009-3-30      ;;
13. ;;; ============================================================================;;
14. (defun RemoveItem (item lst / x tmplst)
15.   (foreach x (vl-remove item lst)
16.     (if (listp x)
17.       (setq tmplst (append (list (RemoveItem item x)) tmplst))
18.       (setq tmplst (append (list x) tmplst))
19.     )
20.   )
21.   (reverse tmplst)
22. )

;;; ============================================================================;; ;;; 函数名：         ;; ;;; RemoveItem         ;; ;;; 从列表中移去指定的元素（一个不留，支持任意嵌套表）    ;; ;;; 参数：         ;; ;;; 要从列表中移去的元素和一个列表      ;; ;;; 示例：         ;; ;;; (RemoveItem nil (list 121 nil (list "abc" nil "dde" nil 111) "aaa" nil 999));; ;;; -> (121 ("abc" "dde" 111) "aaa" 999)     ;; ;;; By 木子CAD工具 小李子  2009-3-30      ;; ;;; ============================================================================;; (defun RemoveItem (item lst / x tmplst)   (foreach x (vl-remove item lst)     (if (listp x)       (setq tmplst (append (list (RemoveItem item x)) tmplst))       (setq tmplst (append (list x) tmplst))     )   )   (reverse tmplst) )

也可以这样：

2. ;;; ============================================================================;;
3. ;;; 函数名：         ;;
4. ;;; RemoveItem         ;;
5. ;;; 从列表中移去指定的元素（一个不留，支持任意嵌套表）    ;;
6. ;;; 参数：         ;;
7. ;;; 要从列表中移去的元素和一个列表      ;;
8. ;;; 示例：         ;;
9. ;;; (RemoveItem nil (list 121 nil (list "abc" nil "dde" nil 111) "aaa" nil 999));;
10. ;;; -> (121 ("abc" "dde" 111) "aaa" 999)     ;;
11. ;;; By 木子CAD工具 小李子  2009-3-30      ;;
12. ;;; ============================================================================;;
13. (defun RemoveItem (item lst / x tmplst)
14.   (foreach x (vl-remove item lst)
15.     (if (listp x)
16.       (setq tmplst (cons (RemoveItem item x) tmplst))
17.       (setq tmplst (cons x tmplst))
18.     )
19.   )
20.   (reverse tmplst)
21. )

;;; ============================================================================;; ;;; 函数名：         ;; ;;; RemoveItem         ;; ;;; 从列表中移去指定的元素（一个不留，支持任意嵌套表）    ;; ;;; 参数：         ;; ;;; 要从列表中移去的元素和一个列表      ;; ;;; 示例：         ;; ;;; (RemoveItem nil (list 121 nil (list "abc" nil "dde" nil 111) "aaa" nil 999));; ;;; -> (121 ("abc" "dde" 111) "aaa" 999)     ;; ;;; By 木子CAD工具 小李子  2009-3-30      ;; ;;; ============================================================================;; (defun RemoveItem (item lst / x tmplst)   (foreach x (vl-remove item lst)     (if (listp x)       (setq tmplst (cons (RemoveItem item x) tmplst))       (setq tmplst (cons x tmplst))     )   )   (reverse tmplst) )

测试结果：
;|
(RemoveItem "" (list 121 "" (list "abc" "" "dde" "" 111) "aaa" "" 999 000))
-> (121 ("abc" "dde" 111) "aaa" 999 0)
(RemoveItem "" (list 121 "" (list "abc" "" "dde" "" 111) "aaa" "" 999 000
    (list 88 "" 9090 "" "" "AAA" "BBB" ""
          (list "ccc" "" "DDD" ""123)
    )
     )
)
-> (121 ("abc" "dde" 111) "aaa" 999 0 (88 9090 "AAA" "BBB" ("ccc" "DDD" 123)))
|;

jxphklibin

3. ;;;解锁所有图层
4. (defun UnLock_All_Layers ()
5.   (vlax-for n (vla-get-layers
6.   (vla-get-ActiveDocument (vlax-get-acad-object))
7.        )
8.     (vla-put-lock n :vlax-false)
9.   )
10. )
11. ;;;解冻所有图层
12. (defun UnFreeze_All_Layers ()
13.   (vlax-for n (vla-get-layers
14.   (vla-get-ActiveDocument (vlax-get-acad-object))
15.        )
16.     (if (/= (vla-get-name n) (getvar "clayer"))
17.       ;;也可以用 (not (equal (vla-get-activelayer adoc) item))判断
18.       (vla-put-Freeze n :vlax-false)
19.     )
20.   )
21. )

;;;解锁所有图层 (defun UnLock_All_Layers ()   (vlax-for n (vla-get-layers   (vla-get-ActiveDocument (vlax-get-acad-object))        )     (vla-put-lock n :vlax-false)   ) ) ;;;解冻所有图层 (defun UnFreeze_All_Layers ()   (vlax-for n (vla-get-layers   (vla-get-ActiveDocument (vlax-get-acad-object))        )     (if (/= (vla-get-name n) (getvar "clayer"))       ;;也可以用 (not (equal (vla-get-activelayer adoc) item))判断       (vla-put-Freeze n :vlax-false)     )   ) )

qhd_aixin

最简洁代码为：

;; 删除去除字符串中的所有空格
;; by 小李子 木子CAD 2009-3-2
(defun strs->No32 (str /)
  (vl-list->string (vl-remove 32 (vl-string->list str)))
)

这个怎么用啊？

gangxiadexue

感谢学习学习

飞诗(fsxm)

http://bbs.mjtd.com/forum.php?mod=viewthread&tid=60071&replyID=&skin=1

多功能表操作函数以索引 [替代/添加/删除] 表中元素,支持嵌套表!

(defun fsxm-subst-index (lst index_lst var / subst0 subst1)
   (defun subst0 (lst index var / lst2 position)
     (cond ((or (= index T) (> index (1- (length lst))))
     (append lst var)
    )
    ((>= index 0)
     (setq position 0)
     (while (< position index)
       (setq lst2 (cons (car lst) lst2))
       (if (<= position (1- index))(setq lst (cdr lst)))
       (setq position (1+ position))
     )
     (append (reverse lst2) var (cdr lst))
    )
    ((< index 0)
     (append var lst)
    )
     )
   )
   (defun subst1 (lst index_lst var / index)
     (if (cadr index_lst)
       (progn (setq index (car index_lst))
       (subst1 lst
        (list index)
        (list (subst1 (nth index lst) (cdr index_lst) var))
       )
       )
       (subst0 lst (car index_lst) var)
     )
   )
   (if (listp var) t (setq var (list var)))
   (if (listp index_lst) t (setq index_lst (list index_lst)))
   (subst1 lst index_lst var)
)

(defun fsxm-subst-index (lst index_lst var / subst0 subst1)
   (defun subst0 (lst index var / lst2 position)
     (cond ((or (= index T) (> index (1- (length lst))))
     (append lst var)
    )
    ((>= index 0)
     (setq position 0)
     (while (< position index)
       (setq lst2 (cons (car lst) lst2))
       (if (<= position (1- index))(setq lst (cdr lst)))
       (setq position (1+ position))
     )
     (append (reverse lst2) var (cdr lst))
    )
    ((< index 0)
     (append var lst)
    )
     )
   )
   (defun subst1 (lst index_lst var / index)
     (if (cadr index_lst)
       (progn (setq index (car index_lst))
       (subst1 lst
        (list index)
        (list (subst1 (nth index lst) (cdr index_lst) var))
       )
       )
       (subst0 lst (car index_lst) var)
     )
   )
   (if (listp var) t (setq var (list var)))
   (if (listp index_lst) t (setq index_lst (list index_lst)))
   (subst1 lst index_lst var)
)

使用方法如：

(setq lst '(0 1 2 (30 31 32 (330 331 332)) 4 5 6 (70 71 72) 8 9))

替代
(fsxm-subst-index lst 2 "test")
->(0 1 "test" (30 31 32 (330 331 332)) 4 5 6 (70 71 72) 8 9)

删除
(fsxm-subst-index lst 2 nil)
->(0 1 (30 31 32 (330 331 332)) 4 5 6 (70 71 72) 8 9)

批量插入
(fsxm-subst-index lst '(3 3 0.5) '("test1" "test2"))
->(0 1 2 (30 31 32 (330 "test1" "test2" 331 332)) 4 5 6 (70 71 72) 8 9)

caoyin

fsxm发表于2009-4-24 12:08:00http://bbs.mjtd.com/forum.php?mod=viewthread&tid=60071&replyID=&skin=1............. 

高手来了，多贴点东西让咱学习一下噻！！

飞诗(fsxm)

caoyin老大,"高手"两字不敢当啊~!
潜水多年了,Lisp也忘记的差不多了!
只能多拿出点以前的老本,给老大你捧场哈!
;;建立目录.支持嵌套目录名.(递归的简单运用)

2. (defun fsxm-mkdir (dir / dir2)
3.   (cond ((vl-directory-files dir))
4. ((= (setq dir2 (vl-filename-directory dir)) dir) nil)
5. (t (fsxm-mkdir dir2) (vl-mkdir dir))
6.   )
7. )

(defun fsxm-mkdir (dir / dir2)   (cond ((vl-directory-files dir)) ((= (setq dir2 (vl-filename-directory dir)) dir) nil) (t (fsxm-mkdir dir2) (vl-mkdir dir))   ) )

1.如果目录名存在,就返回目录内所有文件名.
如fsxm-mkdir "c:\\windows")
2.如果建立失败就返回nil.
如fsxm-mkdir "c:")
3.如果成功就返回T.
如: (fsxm-mkdir "c:\\1\\2\\3\\4\\5\\6\\7\\8\\9")