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

zhongzilei · 发表于 2009-2-5 00:41

本帖最后由作者于 2009-2-5 0:42:34 编辑

真是高手如云，羡慕呀。真的要好好学习一下lisp了，祝高手们牛气冲天，更牛

zhongzilei · 发表于 2009-2-5 16:33

caoyin发表于2008-12-18 14:04:00....此程序缺少函数(LTAX:DOC) (LTAX:BLKS)呀，请楼主补上吧

caoyin · 发表于 2009-2-6 09:21

函数已经添加

zhongzilei · 发表于 2009-2-6 23:27

试了新修改的程序不能用呀，看看怎么回事

caoyin · 发表于 2009-2-7 11:00

回49楼 jxphklibin：KEYWD在此处不是函数，相当于(if KEYWD (strcat KEYWD " "))
回53楼 zhongzilei：那个程序？发现什么问题？

zhongzilei · 发表于 2009-2-7 19:17

ncopy.lsp程序，我这里下了几次新修改过函数的程序，加载后都没有什么反应

caoyin · 发表于 2009-2-8 09:58

;;我在不同版本使用是发现了一些问题，修改了一下
(defun C:NCOPY
(/ OS CM QA EM SS NEN $LT-ENTSEL$ EN ES EP P1 ELST TYP EN1 PP P2 SC DOC BLKS BLK)
;;-----------------------------------------------------
;;本程序支持函数
(defun lt:list-sub (lst sta len / item n)
(setq item (nth sta lst) n (- (length lst) sta))
(while (/= (length (setq lst (member item lst))) n) (setq lst (cdr lst)))
(setq item (nth (1- len) lst) lst (reverse lst))
(while (/= (length (setq lst (member item lst))) len) (setq lst (cdr lst)))
(reverse lst)
)
(defun lt:ss->list (ss / lst)
(foreach x (ssnamex ss)
(if (= (car x) 3) (setq lst (append lst (list (cadr x)))))
)
lst
)
;;-----------------------------------------------------
(sssetfirst nil nil)
(setq OS (getvar "osmode")
CM (getvar "cmdecho")
QA (getvar "qaflags")
EM (getvar "explmode")
)
(setvar "cmdecho" 0)
(setvar "osmode" 0)
(setvar "qaflags" 1)
(setvar "explmode" 1)
(setq SS (ssadd))
(princ "\n复制块、多段线、多线或标注中的套嵌对象...")
(setq $LT-ENTSEL$ T)
(while (setq NEN (lt:entsel nil nil nil))
(if (= (length NEN) 2)
(setq EN (car NEN))
(setq EN (car (last NEN)))
)
(cond ((if (ssmemb EN SS)
(princ "重复选择，忽略。")
(progn
(setq ELST (entget EN)
TYP (cdr (assoc 0 ELST))
)
nil
)
)
)
((= TYP "MLINE")
(entmake ELST)
(setq EN1 (entlast))
(command "_.explode" EN1 "")
(setq ES (lt:ss->list (ssget "_P"))
P1 (cadr NEN)
EN1 (nth (car (vl-sort-i
(mapcar '(lambda (X)
(distance (vlax-curve-getClosestPointTo X P1) P1)
)
ES
)
'<
)
)
ES
)
)
(foreach X ES
(if (not (eq X EN1)) (entdel X))
)
)
((= TYP "LWPOLYLINE")
(setq PP (fix (vlax-curve-getParamAtPoint
EN
(apply 'vlax-curve-getClosestPointTo NEN)
)
)
ELST1 (lt:list-sub ELST 0 (vl-position (assoc 10 ELST) ELST))
ELST1 (subst '(70 . 0) (assoc 70 ELST1) ELST1)
ELST2 (member (assoc 10 ELST) ELST)
ELST3 (member (assoc 210 ELST2) ELST2)
)
(if (and (vlax-curve-isClosed EN)
(/= (setq EP (vlax-curve-getEndParam EN)) 1)
(= EP (1+ PP))
)
(setq ELST2 (append (lt:list-sub ELST2 (* PP 4) 4)
(lt:list-sub ELST2 0 4)
)
)
(setq ELST2 (lt:list-sub ELST2 (* PP 4) 8))
)
(entmake (append ELST1 ELST2 ELST3))
(setq EN1 (entlast))
)
((= TYP "INSERT")
(setq SC (mapcar '(lambda (X) (assoc X ELST)) '(10 41 42 43 50))
P1 (cdar SC)
SC (cdr SC)
)
(entmake (entget (car NEN)))
(setq EN1 (entlast)
DOC (vla-get-activedocument (vlax-get-acad-object))
BLKS (vla-get-Blocks DOC)
)
(vlax-invoke DOC
'CopyObjects
(list (en2obj EN1))
(setq BLK (vla-add BLKS (vlax-3d-point '(0 0 0)) "*U"))
)
(setq BLK (vla-get-name BLK))
(entdel EN1)
(entmake (vl-list* '(0 . "INSERT") (cons 2 BLK) (cons 10 P1) SC))
(setq EN1 (entlast))
(vl-catch-all-apply 'vla-delete (list (vla-item BLKS BLK)))
)
((= TYP "ATTRIB")
(princ "\n所选对象为属性，自动转换为单行文字...")
(setq ELST (vl-remove-if '(lambda (X)
(member (car X) '(-1 0 330 5 100 2 70 71 72 74))
)
ELST
)
)
(entmake (cons '(0 . "TEXT") ELST))
(setq EN1 (entlast))
)
((= TYP "DIMENSION")
(entmake (entget (car NEN)))
(setq EN1 (entlast))
)
(T (command "_.copy" EN "" "0,0" "0,0")
(while (/= 0 (getvar "cmdactive")) (command ""))
(setq EN1 (entlast))
)
)
(if EN1
(progn
(command "_.draworder" EN1 "" "_f")
(ssadd EN1 SS)
(redraw EN1 3)
)
)
)
(if (and SS (/= (sslength SS) 0))
(progn
(setvar "osmode" OS)
(if (setq P1 (getpoint "\n指定基点 <原位置>: "))
(progn
(command "_.move" SS "" "_non" P1)
(princ "指定第二点: ")
(command "\")
)
)
(if (equal (getvar "lastpoint") P1 1e-7)
(command "_.erase" SS "")
)
(command "_.select" SS "")
(if (setq SS1 (ssget "_P" '((0 . "INSERT"))))
(command "_.explode" SS1 "");;;
)
(command "_.select" SS "")
)
)
(setvar "cmdecho" CM)
(setvar "osmode" OS)
(setvar "qaflags" QA)
(setvar "explmode" EM)
(princ)
)

;;我在不同版本使用是发现了一些问题，修改了一下
(defun C:NCOPY
   (/ OS CM QA EM SS NEN $LT-ENTSEL$ EN ES EP P1 ELST TYP EN1 PP P2 SC DOC BLKS BLK)
   ;;-----------------------------------------------------
   ;;本程序支持函数
   (defun lt:list-sub (lst sta len / item n)
   (setq item (nth sta lst) n (- (length lst) sta))
   (while (/= (length (setq lst (member item lst))) n) (setq lst (cdr lst)))
   (setq item (nth (1- len) lst) lst (reverse lst))
   (while (/= (length (setq lst (member item lst))) len) (setq lst (cdr lst)))
   (reverse lst)
   )
   (defun lt:ss->list (ss / lst)
   (foreach x (ssnamex ss)
     (if (= (car x) 3) (setq lst (append lst (list (cadr x)))))
   )
   lst
   )
   ;;-----------------------------------------------------
   (sssetfirst nil nil)
   (setq OS (getvar "osmode")
         CM (getvar "cmdecho")
         QA (getvar "qaflags")
         EM (getvar "explmode")
   )
   (setvar "cmdecho" 0)
   (setvar "osmode" 0)
   (setvar "qaflags" 1)
   (setvar "explmode" 1)
   (setq SS (ssadd))
   (princ "\n复制块、多段线、多线或标注中的套嵌对象...")
   (setq $LT-ENTSEL$ T)
   (while (setq NEN (lt:entsel nil nil nil))
     (if (= (length NEN) 2)
       (setq EN (car NEN))
       (setq EN (car (last NEN)))
     )
     (cond ((if (ssmemb EN SS)
              (princ "重复选择，忽略。")
              (progn
                (setq ELST (entget EN)
                      TYP  (cdr (assoc 0 ELST))
                )
                nil
              )
            )
           )
           ((= TYP "MLINE")
            (entmake ELST)
            (setq EN1 (entlast))
            (command "_.explode" EN1 "")
            (setq ES  (lt:ss->list (ssget "_P"))
                  P1  (cadr NEN)
                  EN1 (nth (car (vl-sort-i
                                  (mapcar '(lambda (X)
                                             (distance (vlax-curve-getClosestPointTo X P1) P1)
                                           )
                                          ES
                                  )
                                  '<
                                )
                           )
                           ES
                      )
            )
            (foreach X ES
              (if (not (eq X EN1)) (entdel X))
            )
           )
           ((= TYP "LWPOLYLINE")
            (setq PP    (fix (vlax-curve-getParamAtPoint
                               EN
                               (apply 'vlax-curve-getClosestPointTo NEN)
                             )
                        )
                  ELST1 (lt:list-sub ELST 0 (vl-position (assoc 10 ELST) ELST))
                  ELST1 (subst '(70 . 0) (assoc 70 ELST1) ELST1)
                  ELST2 (member (assoc 10 ELST) ELST)
                  ELST3 (member (assoc 210 ELST2) ELST2)
            )
            (if (and (vlax-curve-isClosed EN)
                     (/= (setq EP (vlax-curve-getEndParam EN)) 1)
                     (= EP (1+ PP))
                )
              (setq ELST2 (append (lt:list-sub ELST2 (* PP 4) 4)
                                  (lt:list-sub ELST2 0 4)
                          )
              )
              (setq ELST2 (lt:list-sub ELST2 (* PP 4) 8))
            )
            (entmake (append ELST1 ELST2 ELST3))
            (setq EN1 (entlast))
           )
           ((= TYP "INSERT")
            (setq SC (mapcar '(lambda (X) (assoc X ELST)) '(10 41 42 43 50))
                  P1 (cdar SC)
                  SC (cdr SC)
            )
            (entmake (entget (car NEN)))
            (setq EN1 (entlast)
                  DOC (vla-get-activedocument (vlax-get-acad-object))
                  BLKS (vla-get-Blocks DOC)
            )
            (vlax-invoke DOC
                         'CopyObjects
                         (list (en2obj EN1))
                         (setq BLK (vla-add BLKS (vlax-3d-point '(0 0 0)) "*U"))
            )
            (setq BLK (vla-get-name BLK))
            (entdel EN1)
            (entmake (vl-list* '(0 . "INSERT") (cons 2 BLK) (cons 10 P1) SC))
            (setq EN1 (entlast))
            (vl-catch-all-apply 'vla-delete (list (vla-item BLKS BLK)))
           )
           ((= TYP "ATTRIB")
            (princ "\n所选对象为属性，自动转换为单行文字...")
            (setq ELST (vl-remove-if '(lambda (X)
                                        (member (car X) '(-1 0 330 5 100 2 70 71 72 74))
                                      )
                                     ELST
                       )
            )
            (entmake (cons '(0 . "TEXT") ELST))
            (setq EN1 (entlast))
           )
           ((= TYP "DIMENSION")
            (entmake (entget (car NEN)))
            (setq EN1 (entlast))
           )
           (T (command "_.copy" EN "" "0,0" "0,0")
              (while (/= 0 (getvar "cmdactive")) (command ""))
              (setq EN1 (entlast))
           )
     )
     (if EN1
       (progn
         (command "_.draworder" EN1 "" "_f")
         (ssadd EN1 SS)
         (redraw EN1 3)
       )
     )
   )
   (if (and SS (/= (sslength SS) 0))
     (progn
       (setvar "osmode" OS)
       (if (setq P1 (getpoint "\n指定基点 <原位置>: "))
         (progn
           (command "_.move" SS "" "_non" P1)
           (princ "指定第二点: ")
           (command "\")
         )
       )
       (if (equal (getvar "lastpoint") P1 1e-7)
         (command "_.erase" SS "")
       )
       (command "_.select" SS "")
       (if (setq SS1 (ssget "_P" '((0 . "INSERT"))))
         (command "_.explode" SS1 "");;;
       )
       (command "_.select" SS "")
     )
   )
   (setvar "cmdecho" CM)
   (setvar "osmode" OS)
   (setvar "qaflags" QA)
   (setvar "explmode" EM)
   (princ)
)

zhongzilei · 发表于 2009-2-8 10:35

版主，在CAD2006下试了还是不行的，输入命令有如下提示,就结束了

命令: ap
APPLOAD 已成功加载 NCOPY.lsp。

命令:
命令:
命令: NCOPY

复制块、多段线、多线或标注中的套嵌对象...
命令:

caoyin · 发表于 2009-2-8 11:30

你一行一行代码测试一下，把出错的地方发给我看看

zhongzilei · 发表于 2009-2-8 12:11

缺少函数T:ENTSEL，加上即可以

但复制块中对象时会提示如下信息:

no function definition: EN2OBJ

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

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

回复：（zhongzilei）以下是引用caoyin在2008-12-18 1...